Regrouper plusieurs lignes de fichiers différents dans une feuille unique
Bonjour les experts !
J'ai un petit grand souci
Je souhaite une solution me permettant de regrouper les lignes non vides de plusieurs feuilles Excel dans une feuille unique nouvelle.
Par exemple, j'ai 20 fichiers Excel nommés de A à T et dans chaque feuille il y a un nombre de lignes déterminés non égaux mais au nombre de colonnes égaux.
Je désire une solution pour créer un nouveau fichier et y copier automatiquement et respectivement toutes les lignes de A, de B jusqu'à T
J'attends avec impatience vos lumières.
Bonjour,
Une piste !
Les valeurs seront inscrites dans la feuille nommée "Feuil1" (à adapter si différent) et dans le classeur qui contiendra cette macro. Attention, ne pas mettre le classeur dans le même dossier que les autres classeurs où seront récupérées les valeurs.
Au lancement du code, une boite de dialogue demande de choisir le dossier où se trouvent les classeurs :
Sub Test()
Dim Cls As Workbook
Dim Fe As Worksheet
Dim Plage As Range
Dim Tbl() As String
Dim I As Integer
Dim Chemin As String
Dim Lig As Long
With Application.FileDialog(4)
If .Show = -1 Then Chemin = .SelectedItems(1) & "\"
End With
If Chemin = "" Then Exit Sub
'récupère les noms des classeurs
Tbl = EnumFichiers(Chemin, ".xls*") 'astérisque pour tous les fichiers Excel (.xls, .xlsx, .xlsm, etc...)
'si initialisé...
If Not (Not Tbl) Then
Application.ScreenUpdating = False
'boucle sur le tableau
For I = 1 To UBound(Tbl)
'ouvre le classeur
Set Cls = Workbooks.Open(Chemin & Tbl(I))
For Each Fe In Cls.Worksheets
Set Plage = DefPlage(Fe, 1, 1)
With ThisWorkbook.Worksheets("Feuil1")
Lig = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 'sur colonne A
.Range(.Cells(Lig, 1), .Cells(Lig - 1 + Plage.Rows.Count, Plage.Columns.Count)).Value = Plage.Value
End With
Next Fe
'referme
Cls.Close False
Next I
End If
Application.ScreenUpdating = False
End Sub
Function EnumFichiers(Chemin As String, Extension As String) As String()
Dim TableauFichiers() As String
Dim Fichier As String
Dim I As Integer
'complète le chemin le cas échéant
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
'récupère seulement les fichiers Excel
Fichier = Dir(Chemin & "*" & Extension)
'boucle sur les fichiers du dossier
Do While (Len(Fichier) > 0)
I = I + 1
ReDim Preserve TableauFichiers(1 To I)
TableauFichiers(I) = Fichier
Fichier = Dir()
Loop
'retourne le tableau des noms de fichiers
EnumFichiers = TableauFichiers()
End Function
Function DefPlage(Fe As Worksheet, Optional L As Long = 1, Optional C As Long = 1) As Range
On Error GoTo Fin
With Fe
Set DefPlage = .Range(.Cells(L, C), _
.Cells(.Cells.Find("*", .[A1], -4123, , _
1, 2).Row, .Cells.Find("*", .[A1], -4123, , _
2, 2).Column))
End With
Exit Function
Fin:
Set DefPlage = Nothing
End FunctionBonjour !
Merci infiniment pour cette contribution. Je l'ai testé mais seules les valeurs du premier fichier sont affichées dans le classeur avec macro. Auparavant ce message apparaît. "variable objet ou variable de bloc with non définie"
autre chose, la macro ouvre aussi en même temps le fichier dont les données sont récupérées. S'il en y a plusieurs cela peut être gênant. Est-il possible qu'elle ne les ouvre pas ?
Merci
Bonjour,
Le message d'erreur est probablement dû au fait qu'une ou plusieurs feuilles du classeur ouvert est totalement vide donc, la variable Plage est Nothing. J'ai corrigé le code de la Sub "Test" :
Sub Test()
Dim Cls As Workbook
Dim Fe As Worksheet
Dim Plage As Range
Dim Tbl() As String
Dim I As Integer
Dim Chemin As String
Dim Lig As Long
With Application.FileDialog(4)
If .Show = -1 Then Chemin = .SelectedItems(1) & "\"
End With
If Chemin = "" Then Exit Sub
'récupère les noms des classeurs
Tbl = EnumFichiers(Chemin, ".xls*") 'astérisque pour tous les fichiers Excel (.xls, .xlsx, .xlsm, etc...)
'si initialisé...
If Not (Not Tbl) Then
Application.ScreenUpdating = False
'boucle sur le tableau
For I = 1 To UBound(Tbl)
'ouvre le classeur
Set Cls = Workbooks.Open(Chemin & Tbl(I))
For Each Fe In Cls.Worksheets
Set Plage = DefPlage(Fe, 1, 1)
If Not Plage Is Nothing Then
With ThisWorkbook.Worksheets("Feuil1")
Lig = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 'sur colonne A
.Range(.Cells(Lig, 1), .Cells(Lig - 1 + Plage.Rows.Count, Plage.Columns.Count)).Value = Plage.Value
End With
End If
Next Fe
'referme
Cls.Close False
Next I
End If
Application.ScreenUpdating = True
End Subautre chose, la macro ouvre aussi en même temps le fichier dont les données sont récupérées. S'il en y a plusieurs cela peut être gênant. Est-il possible qu'elle ne les ouvre pas ?
La Sub ouvre et referme le classeur une fois les valeurs récupérées, c'est plus compliqué de récupérer les valeur avec les classeurs fermés, il faut utiliser ADO et dans ton cas, ce n'est pas vraiment nécéssaire
Formidable ! vous êtes ingénieux. Merci beaucoup
J'ai conservé la première macro en supprimant les feuilles vides de chaque fichier et ça marche comme sur des roulettes.
Pour la seconde, Excel me signale un problème de Sub (test) et met en surbrillance la ligne Tbl = Enumfichiers
Bonjour,
Le second code posté doit venir en remplacement de la Sub "Test" du premier post mais les autres fonctions doivent être conservées car utilisées aussi dans le second code
Bonjour Theze
Puis avoir la macro définitive complète svp ? Il me semble que j'ai confondu les choses
Bonjour,
Voici le code complet :
Sub Test()
Dim Cls As Workbook
Dim Fe As Worksheet
Dim Plage As Range
Dim Tbl() As String
Dim I As Integer
Dim Chemin As String
Dim Lig As Long
With Application.FileDialog(4)
If .Show = -1 Then Chemin = .SelectedItems(1) & "\"
End With
If Chemin = "" Then Exit Sub
'récupère les noms des classeurs
Tbl = EnumFichiers(Chemin, ".xls*") 'astérisque pour tous les fichiers Excel (.xls, .xlsx, .xlsm, etc...)
'si initialisé...
If Not (Not Tbl) Then
Application.ScreenUpdating = False
'boucle sur le tableau
For I = 1 To UBound(Tbl)
'ouvre le classeur
Set Cls = Workbooks.Open(Chemin & Tbl(I))
For Each Fe In Cls.Worksheets
Set Plage = DefPlage(Fe, 1, 1)
If Not Plage Is Nothing Then
With ThisWorkbook.Worksheets("Feuil1")
Lig = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 'sur colonne A
.Range(.Cells(Lig, 1), .Cells(Lig - 1 + Plage.Rows.Count, Plage.Columns.Count)).Value = Plage.Value
End With
End If
Next Fe
'referme
Cls.Close False
Next I
End If
Application.ScreenUpdating = True
End Sub
Function EnumFichiers(Chemin As String, Extension As String) As String()
Dim TableauFichiers() As String
Dim Fichier As String
Dim I As Integer
'complète le chemin le cas échéant
If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
'récupère seulement les fichiers Excel
Fichier = Dir(Chemin & "*" & Extension)
'boucle sur les fichiers du dossier
Do While (Len(Fichier) > 0)
I = I + 1
ReDim Preserve TableauFichiers(1 To I)
TableauFichiers(I) = Fichier
Fichier = Dir()
Loop
'retourne le tableau des noms de fichiers
EnumFichiers = TableauFichiers()
End Function
Function DefPlage(Fe As Worksheet, Optional L As Long = 1, Optional C As Long = 1) As Range
On Error GoTo Fin
With Fe
Set DefPlage = .Range(.Cells(L, C), _
.Cells(.Cells.Find("*", .[A1], -4123, , _
1, 2).Row, .Cells.Find("*", .[A1], -4123, , _
2, 2).Column))
End With
Exit Function
Fin:
Set DefPlage = Nothing
End Functionimpeccable. Merci beaucoup