Fusionner plusieurs fichiers Excel en un seul par sélection

Bonjour, je suis novice en VBA, je souhaiterais avoir un code qui me permettrais de sélectionner à partir d'un une "boite de dialogue"

Plusieurs fichier excel, et en faire un seul général, la subtilité c'est que mon fichier général devra copier uniquement les Page nommé,"feuil1" et que la 'dans la colonne A on mettra le nom du fichier ou provient la ligne.

Merci d'avance pour votre aide

bonjour,

une proposition

Sub aargh()
    autsec = Application.AutomationSecurity
    Application.AutomationSecurity = msoAutomationSecurityForceDisable 'on n'autorise pas l'exécution des macros dans les fichiers à ouvrir
    Set ws = ThisWorkbook.Sheets("sheet1")    'feuille de consolidation
    dlws = ws.Cells(Rows.Count, 1).End(xlUp).Row
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        If .Show = False Then Exit Sub
        For i = 1 To .SelectedItems.Count
            Set wb = Workbooks.Open(.SelectedItems(i))
            Set wsi = wb.Sheets(1)
            dlwsi = wsi.Cells(Rows.Count, 1).End(xlUp).Row
            dcwsi = wsi.Cells(1, Columns.Count).End(xlToLeft).Column
            ws.Range("A" & dlws + 1 & ":A" & dlws + dlwsi - 1) = wb.Name
            wsi.Range("A2").Resize(dlwsi, dcwsi).Copy ws.Cells(dlws + 1, 2)
            wb.Close True
        Next i
    End With
    Application.AutomationSecurity = autsec
End Sub

Parfais c'est exactement ça, un grand merci !!

Il y a quand même un petit soucis, car en effet le code marche très bien mais uniquement pour des fichiers ayant un nombre de ligne inférieur à 4500 environ. Une fois ce nombre de ligne atteint le code ne copie que le Nom du fichier et ne traite plus les autres fichier sélectionné

Je traite dès fichier de 5000 lignes environ

bonjour,

reçois-tu un message d'erreur ?

Bonjour, non il ne m'affiche aucun message d'erreurs

bonjour,

peux-tu me mettre un exemple de fichier qui ne se copie pas ? via cjoint si fichier trop gros, anonymisé si nécessaire.

Voici

re-Bonjour,

là tu m'as mis le fichier avec la macro, pas un fichier qui ne se copie pas.

je t'envoie 4 fichier "acopier"

deux en xls

et deux en xlsx

Il semble que le ficher 3 est trop lourd mais tu peux essayer avec c'est 3 fichiers, seul deux son copier pour m'as part

bonjour,

une correction

Sub aargh()
    autsec = Application.AutomationSecurity
    Application.AutomationSecurity = msoAutomationSecurityForceDisable    'on n'autorise pas l'exécution des macros dans les fichiers à ouvrir
    Set ws = ThisWorkbook.Sheets("sheet1")    'feuille de consolidation
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        If .Show = False Then Exit Sub
        For i = 1 To .SelectedItems.Count
            dlws = ws.Cells(Rows.Count, 1).End(xlUp).Row
            Set wb = Workbooks.Open(.SelectedItems(i))
            Set wsi = wb.Sheets(1)
            dlwsi = wsi.Cells(Rows.Count, 1).End(xlUp).Row
            dcwsi = wsi.Cells(1, Columns.Count).End(xlToLeft).Column
            ws.Range("A" & dlws + 1 & ":A" & dlws + dlwsi - 1) = wb.name
            wsi.Range("A2").Resize(dlwsi, dcwsi).Copy ws.Cells(dlws + 1, 2)
            wb.Close True
        Next i
    End With
    Application.AutomationSecurity = autsec
End Sub

PARFAIT !!! Ça fonction super bien un grand merci 8)

Du coup si j'aimerais que ça commence à copier mes fichiers à la premiere ligne je modifie A2 par A1, mais tu coup pour la toute dernière ligne il n'y a pas le Nom du fichier

bonjour,

voici une adaptation

Sub aargh()
    autsec = Application.AutomationSecurity
    Application.AutomationSecurity = msoAutomationSecurityForceDisable    'on n'autorise pas l'exécution des macros dans les fichiers à ouvrir
    Set ws = ThisWorkbook.Sheets("sheet1")    'feuille de consolidation
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        If .Show = False Then Exit Sub
        For i = 1 To .SelectedItems.Count
            dlws = ws.Cells(Rows.Count, 1).End(xlUp).Row
            If dlws = 1 Then dlws = 0 ' supprimer cette instruction si copie doit commencer sur la ligne 2 de consolidation
            Set wb = Workbooks.Open(.SelectedItems(i))
            Set wsi = wb.Sheets(1)
            dlwsi = wsi.Cells(Rows.Count, 1).End(xlUp).Row
            dcwsi = wsi.Cells(1, Columns.Count).End(xlToLeft).Column
            ws.Range("A" & dlws + 1 & ":A" & dlws + dlwsi) = wb.Name
            wsi.Range("A1").Resize(dlwsi, dcwsi).Copy ws.Cells(dlws + 1, 2)
            wb.Close True
        Next i
    End With
    Application.AutomationSecurity = autsec
End Sub