Fusion de plusieurs fichiers en un seul

Option Explicit

Sub Test()
'Déclaration des variables
Dim Chemin As String, Fichier As String
Dim Onglet As Worksheet
Dim OngletCible As String
Dim OngletOK As Boolean

OngletCible = "DB"
ThisWorkbook.Sheets(OngletCible).Cells.Clear
Chemin = ThisWorkbook.Path

'Si classeur non sauvegardé alors pas de chemin
If Chemin <> "" Then
 'Filtre uniquement sur les fichiers Excel
 Fichier = Dir(Chemin & "\*.*xls*")
 'Améliore vitesse et aspect du traitement en désactivant le rafraiche
 Application.ScreenUpdating = False
 Do While Fichier <> ""
    If Fichier <> ThisWorkbook.Name Then
        Workbooks.Open Filename:=Chemin & "\" & Fichier
        
        'Test si onglet existe
         OngletOK = False
         For Each Onglet In Workbooks(Fichier).Sheets
          If Onglet.Name = OngletCible Then OngletOK = True: Exit For
         Next
        
        If OngletOK Then
         Workbooks(Fichier).Sheets(OngletCible).Range("A1").CurrentRegion.Resize(1).Copy ThisWorkbook.Sheets(OngletCible).Range("A1")
         Workbooks(Fichier).Sheets(OngletCible).Range("A1").CurrentRegion.Offset(1, 0).Copy ThisWorkbook.Sheets(OngletCible).Range("A1").Offset(ThisWorkbook.Sheets(OngletCible).Range("A1").CurrentRegion.Rows.Count, 0)
        End If
        
        Workbooks(Fichier).Close False

    End If
    Fichier = Dir
 Loop

' Réactive Le rafraiche écran
 Application.ScreenUpdating = True
End If
End Sub

Option Explicit

Sub HC_Global()
'Déclaration des variables
Dim Path As String, File As String
Dim Worksheet As Worksheet
Dim Target_Worksheet As String
Dim LigneRef As Long
Dim OK_Worksheet As Boolean, Début As Boolean
Dim Nom As Name

Target_Worksheet = "DB"
ThisWorkbook.Sheets(Target_Worksheet).Cells.Clear
Path = ThisWorkbook.Path
'Monte le flag de Start
Début = True

'If unsaved file, then no path => always save the file before executing the macro
If Path <> "" Then
 'Filter only on Excel files
 File = Dir(Path & "\*.*xls*")
 'Only "esthetic" : improves speed and processing appearance (deactivating sreen update)
 Application.ScreenUpdating = False
 Do While File <> ""
    If File <> ThisWorkbook.Name Then
        Workbooks.Open Filename:=Path & "\" & File
        
        'Test if worksheet exists
         OK_Worksheet = False
         For Each Worksheet In Workbooks(File).Sheets
          If Worksheet.Name = Target_Worksheet Then OK_Worksheet = True: Exit For
         Next
       'Si feuille ok alors copie du contenu du fichier X vers la base de données
        If OK_Worksheet Then
        'Décalage de l'entête si pas premier fichier copié
         LigneRef = IIf(Début, 1, 2)
         Workbooks(File).Sheets(Target_Worksheet).Range("A" & LigneRef).CurrentRegion.Offset(1, 0).Copy ThisWorkbook.Sheets(Target_Worksheet).Range("A1").Offset(ThisWorkbook.Sheets(Target_Worksheet).Range("A1").CurrentRegion.Rows.Count, 0)

        'Si dans ce classeur un champ nommé Budget alors suppression
         For Each Nom In ThisWorkbook.Names
          If Nom.Name = "Budget" Then Nom.Delete
         Next
        'Supprime le flag de start
         Début = False
        End If
        
        Workbooks(File).Close False

    End If
    File = Dir
 Loop

' Re-activates screen update
 Application.ScreenUpdating = True
End If
End Sub

Sub zzzzzzzzzz()
Dim i#, pfile$
Dim wb As Workbook, ws As Worksheet
Dim rng1 As Range, rng2 As Range, tablo
For i = 1 To 3
    Set rng1 = ActiveSheet.Range("A65000").End(xlUp).Offset(1)
    pfile = ActiveWorkbook.Path & "\" & Feuil1.Cells(i, 1) 'à adapter
    If Dir(pfile) <> "" Then
        Application.ScreenUpdating = False
        Set wb = Workbooks.Open(pfile)
        With wb
            On Error Resume Next
            Set ws = .Sheets("DB")
            On Error GoTo 0
            If Not ws Is Nothing Then
                Set rng2 = ws.Range("A1").CurrentRegion
                With rng2
                    tablo = .Offset(1).Resize(.Rows.Count - 1)
                End With
            End If
            rng1.Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo
        End With
        wb.Close False
    End If
Next
End Sub