Re : Regroupement de fichiers excel + ajout d'une colonne référencant la source
Re-bonjour,
En fait, le décalage apparait à cause d'un problème sur la selection des données de chaque fichiers qui est non exhaustive : La selection s'arrete sur la derniere ligne ou la cellule A est remplie, alors qu'il y a encore des lignes à prendre en compte, bien que la cellule A soit vide.
-> Dans le fichier ALMANDIN par exemple, la selection s'arrête ligne 36, car les cellules A37 à A41 sont vides, mais j'ai bien des données à prendre en compte sur ces lignes 37 à 41.
En revanche, la macro reprend bien 41 lignes pour le fichier ALMANDIN et a bien rempli la colonne A en reprenant le nom du fichier ALMANDIN, mais, à partir de la ligne 37, elle a inséré les données issues du 2ème fichier AMAZONITE, alors qu'en colonne A, c'est le nom du fichier ALMANDIN qui est reporté.
C'est donc la formule de selection des données de chaque fichier qui n'est pas adapté à l'absence de données dans certaines cellules de la colonne A :
Je recopie la macro ci-dessous en surlignant le code qui serait à adapter à ce cas particulier :
Macro qui permet de compiler les informations contenues dans
' différents fichier pour les regrouper dans un fichier récapitulatif
' Sélection d'un répertoire contenant les fichiers
' Par : GCExcel
'-------------------------------------------------------------------------------
Sub Creer_Recapitulatif()
Dim sRep As String 'Répertoire ou filtre
Dim sFichier As String
Dim wb As Workbook, ws As Worksheet, rg As Range
Dim wbR As Workbook, wsR As Worksheet, rgC As Range
Dim tablo
Set wbR = ThisWorkbook 'fichier récapitulatif
Set wsR = wbR.Sheets("Recap") 'onglet récapitulatif
Application.ScreenUpdating = False
sRep = ChoisirRepertoire & "\"
'Boîte de dialogue pour choisir répertoire
sFichier = Dir(sRep)
Do While sFichier <> ""
If sFichier <> wbR.Name Then
Set wb = Workbooks.Open(sRep & sFichier) 'ouvrir le fichier
Set ws = wb.Sheets(1) 'les données se trouvent dans le 1er onglet
Set rg = ws.Range("A2").CurrentRegion 'sélection des données tablo = rg 'mettre les données dans un tablo pour copier ensuite
wsR.Range("A65000").End(xlUp).Offset(1, 0).Resize(rg.Rows.Count, 1) = wb.Name 'nom du fichier
wsR.Range("B65000").End(xlUp).Offset(1, 0).Resize(rg.Rows.Count, 4) = tablo 'données
wb.Close savechanges:=True
End If
sFichier = Dir 'trouve le prochain fichier
Loop
Application.ScreenUpdating = True
End Sub
Function ChoisirRepertoire() As String
Dim diaFolder As FileDialog
' Ouvrir la boîte de dialog
On Error Resume Next
Set diaFolder = Application.FileDialog(msoFileDialogFolderPicker)
diaFolder.AllowMultiSelect = False
diaFolder.Show
ChoisirRepertoire = diaFolder.SelectedItems(1)
Set diaFolder = Nothing
End Function
Merci !
Jex94