faire d'un classeur multifeuille plusieur classeur monofeuille

[seb.bc]

[RESOLU] faire d'un classeur multifeuille plusieur classeur monofeuille

Bonjour,

J'ai une bonne 50aines de fichier Excel qui contiennent tous entre 30 et 150 feuille. Impossible à gérer, temps d'ouverture et enregistrement trop long.
J'ai fait un bout de code permettant d'enregistrer chaques feuilles du classeur source en un classeur d'une feuille.

Dim chemin
chemin = ActiveWorkbook.Path
ChDir ActiveWorkbook.Path
For i = 1 To Sheets.Count
'ThisWorkbook.Activate
Sheets(i).Copy
ActiveWorkbook.SaveAs Filename:=chemin & "\" & Sheets(i).Name & ".xls"
ActiveWorkbook.Close
Next i

La première boucle fonctionne parfaitement mais au deuxième passage j'ai l'erreur :
Erreur d'execution '9' :
L'indice n'appartient pas à la sélection

Je pense que excel perd les pédales et ne sais plus dans quel classeur il est...
Aidez-moi SVP.

 

[Pierrot93]

Re : faire d'un classeur multifeuille plusieur classeur monofeuille

Bonjour Seb

essaye peut être le code ci dessous :

Option Explicit
Sub test()
Dim chemin As String, ws As Worksheet
chemin = ActiveWorkbook.Path
For Each ws In Worksheets
    ws.Copy
    ActiveWorkbook.Close True, chemin & "\" & ws.Name & ".xls"
Next ws
End Sub

bon après midi
@+

 

[jp14]

Re : faire d'un classeur multifeuille plusieur classeur monofeuille

Bonjour

Macro à tester

Sub copie()
Dim chemin
Dim data1 As String
chemin = ThisWorkbook.Path & "\"
chemin = ActiveWorkbook.Path
'ChDir ActiveWorkbook.Path
For i = 1 To Sheets.Count
'ThisWorkbook.Activate
data1 = Sheets(i).Name
Sheets(i).Copy
ActiveWorkbook.SaveAs Filename:=chemin & "\" & data1 & ".xls"
ActiveWorkbook.Close
Next i
End Sub

JP

 

[seb.bc]

Re : faire d'un classeur multifeuille plusieur classeur monofeuille [RESOLU]

Merci Pierrot93, ça fonctionne nickel...
Merci aussi pour ta contribution jp14.

Bravo également à excel-download.com

 

[Staple1600]

Re : faire d'un classeur multifeuille plusieur classeur monofeuille

Bonjour à tous

J'ai une bonne 50aines de fichier Excel qui contiennent tous entre 30 et 150 feuille.

A tester, car parfois selon le fichier
il peut y avoir un message d'erreur
(si quelqu'un peut m'expliquer ou j'ai fait erreur, merci)

J'ai pas pu tester avec plusieurs fichiers dans un répertoire
(Mais ce code a fonctionné avec un dossier contenant un seul fichier Excel
(vierge de toute données) et contenant plusieurs feuilles)

Sub unefeuille_unclasseur()
'nécessite d'activer Microsoft Scripting Runtime
Dim fso As New FileSystemObject
Dim myFolder As Folder
Dim myFile As File
Dim strPath As String
Dim i As Long
Dim j as Long
Dim sh As Worksheet
'chemin à adapter
strPath = "C:\Temp\

Set myFolder = fso.GetFolder(strPath)
Application.ScreenUpdating = False
Application.DisplayAlerts = False

For Each myFile In myFolder.Files
Workbooks.Open myFile
For i = 1 To Workbooks(myFile.Name).Sheets.Count
            
Workbooks(myFile.Name).Sheets(i).Copy
ActiveWorkbook.SaveAs Filename:=strPath & Workbooks(myFile.Name).Sheets(j).Name & ".xls"
ActiveWorkbook.Close
j=j+1
Next i
Workbooks(myFile.Name).Close False
Next myFile
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set myFile = Nothing
Set myFolder = Nothing
Set fso = Nothing
End Sub

PS: macro d'adaptée à partir de celle-ci: Ce lien n'existe plus

 

[ChTi160]

Re : faire d'un classeur multifeuille plusieur classeur monofeuille

Salut seb.bc
Bonjour le Fil
Bonjour le Forum

en pièce jointe d'autres procèdures qui adaptées peuvent servir Lol
le fichier doit être placé dans le dossier où se trouvent les fichiers à traiter
Le Fichier : Regarde la pièce jointe Fichiers.xls

Bonne fin de journée 😉

 

[ChTi160]

Re : faire d'un classeur multifeuille plusieur classeur monofeuille

re
arff il ne m'en voudra pas lol
Voilà ce que j'ai adapté dans la procèdure de Staple1600
pour inhiber les procèdure WorkBook_Open des fichiers traités
j'ai aussi modifié car j'avais un message d'erreur Sheets(j)

Sub unefeuille_unclasseur()
'nécessite d'activer Microsoft Scripting Runtime
Dim fso As New FileSystemObject
Dim myFolder As Folder
Dim myFile As File
Dim strPath As String
Dim i As Long
Dim sh As Worksheet
'chemin à adapter
strPath = ThisWorkbook.Path & "\" '"C:\Temp\" 'ic j'ai adapté pour moi Lol

Set myFolder = fso.GetFolder(strPath)
With Application
 .ScreenUpdating = False
 .DisplayAlerts = False
 [COLOR=Blue].EnableEvents = False[/COLOR]
End With
For Each myFile In myFolder.Files
  If myFile.Name <> ThisWorkbook.Name Then
Workbooks.Open myFile
For i = 1 To Workbooks(myFile.Name).Sheets.Count
            
Workbooks(myFile.Name).Sheets(i).Copy
With ActiveWorkbook
   .SaveAs Filename:=strPath & Workbooks(myFile.Name).Sheets([COLOR=Red]i[/COLOR]).Name & ".xls"
   .Close
End With
Next i
Workbooks(myFile.Name).Close False
End If
Next myFile
With Application
 .ScreenUpdating = True
 .DisplayAlerts = True
[COLOR=Blue] .EnableEvents = True[/COLOR]
End With
Set myFile = Nothing
Set myFolder = Nothing
Set fso = Nothing
End Sub

Bonne fin de Journée

 

[seb.bc]

Re : faire d'un classeur multifeuille plusieur classeur monofeuille

ça fonctionne telement bien que je me retrouve avec tout un tas de classeurs partout.
j'aimerai que les classeurs monofeuille s'enregistrent dans un répertoire qui reprend le nom du fichier multifeuille. Mais l'extension '.xls' cause une erreur.
Comment récuperer le nom du classeur sans l'extension '.xls' ???

 

[Staple1600]

Re : faire d'un classeur multifeuille plusieur classeur monofeuille

RE


Voici une nouvelle mouture (sans erreur normalement)
(et sans Microsoft Scripting Runtime)

qui copie les fichiers dans C:\Temp

(à modifier)

PS: Il y a une ligne dans le code qui récupére le nom du classeur
cf
Original = Left(Classeur_Dossier.Name, Len(Classeur_Dossier.Name) - 4)

 

[Staple1600]

Re : faire d'un classeur multifeuille plusieur classeur monofeuille

Re

Dernière version (testée OK chez moi)

qui crée les répertoires avec le nom du classeur
puis y crée un classeur par feuille
(avec nom de classeur= nom feuille)

 

[seb.bc]

Re : faire d'un classeur multifeuille plusieur classeur monofeuille

Super, testé chez moi OK
Bravo à tous