Re : exporter les onglets d'un excel en autant de fichier plat
Bonjour
Tu crées un fichier maitre qui va servir à traiter tous tes fichiers et qui va stocker ta macro de traitement
dans un feuille et dans une colonne tu listes tous tes fichiers à ouvrir avec leur adresse précise de
préférence tous stockés dans un même dossier
ta macro va ouvrir chaque fichier, éxécuter le code que tu as écris, fermer le fichier et passer au suivant
voici un code que j'ai adapté il y a quelques temps
Sub GetAllWorksheetNames() ' 22.03.07
'Lister tous les dossiers d'un dossier, creer un lien hypertexte
'pour chaque fichier et lister les feuilles
'Les fichiers ne doivent pas être protégés en ouverture
Dim i As Integer, L As Integer
Dim Ih&, Iw&, Brow&, Trow&, Pfolder
Dim WbResults As Workbook
Dim WbCodeBook As Workbook
Dim WbCodeBookws As Worksheet
Dim WSheet As Worksheet
Dim MyFolderPath As String
Dim MySubFolderPath As String
On Error GoTo errorHandler
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Set WbCodeBook = ThisWorkbook
Set WbCodeBookws = ActiveSheet
'Raz du traitement précédent
'WbCodeBookws.Cells.ClearContents
ActiveWindow.FreezePanes = False
Range("A1") = "Nom Feuille": Range("B1") = "Numéro"
Range("C1") = "Nom Fichier": Range("D1") = "Chemin"
Range("A1
1").Font.Bold = True
Range("A1
1").Interior.ColorIndex = 33
Pfolder = Application.GetOpenFilename
If Pfolder <> Empty Then
Pfolder = Left(Pfolder, InStrRev(Pfolder, "\") - 1)
Else
MsgBox "Procedure abandonnée. Aucun fichier n'est sélectionné."
Exit Sub
End If
With Application.FileSearch
.NewSearch
.LookIn = Pfolder
.SearchSubFolders = True
.FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
L = InStrRev(.FoundFiles(i), "\")
MySubFolderPath = Left(.FoundFiles(i), L - 1)
If .FoundFiles(i) = ThisWorkbook.Path & "\" & ThisWorkbook.Name _
Or Mid(.FoundFiles(i), L + 1) = ThisWorkbook.Name Then
Set WbResults = ThisWorkbook
Else
Set WbResults = Workbooks.Open(.FoundFiles(i))
End If
'Recensement des noms de feuilles en colonne 1
Iw = 0
For Each WSheet In WbResults.Worksheets
If Iw = 0 Then Trow = WbCodeBookws. _
Cells(Rows.Count, 1).End(xlUp)(2, 1).Row
WbCodeBookws.Cells(Rows.Count, 1).End(xlUp)(2, 1) _
= WSheet.Name
Iw = Iw + 1
'numero de feuille en colonne 2
WbCodeBookws.Cells(Rows.Count, 1).End(xlUp)(1, 2) = Iw
Next 'wSheet
Brow = Trow + Iw - 1
'Copie du nom de fichier en colonne 3
WbCodeBookws.Range(WbCodeBookws.Cells(Trow, 3), WbCodeBookws.Cells(Brow, 3)) = Mid(.FoundFiles(i), L + 1)
'Installation du nom complet comme lien hypertexte en colonne 4
For Ih = Trow To Brow
ActiveSheet.Hyperlinks.Add _
Anchor:=WbCodeBookws.Cells(Ih, 4), _
Address:=.FoundFiles(i)
Next Ih
If WbResults.FullName <> ThisWorkbook.FullName Then _
WbResults.Close SaveChanges:=False
Next i
End If
End With
'Tri liste par répertoire, nomfichier, et numero de feuille
Range("A1").CurrentRegion.Sort Key1:=Range("D2"), _
Order1:=xlAscending, Key2:=Range("C2"), _
Order2:=xlAscending, Key3:=Range("B2"), _
Order3:=xlAscending, Header:=xlYes
'Formatage des sorties
WbCodeBookws.Activate
WbCodeBookws.Cells(2, 1).Select
ActiveWindow.FreezePanes = True
WbCodeBookws.Columns("A
").AutoFit
Selection.AutoFilter
WrapSub:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Exit Sub
Set WbResults = Nothing
Set WbCodeBook = Nothing
Set WbCodeBookws = Nothing
errorHandler:
MsgBox "Erreur de traitement... action abandonnée."
Resume WrapSub
End Sub
Bon courage
Flyonets