< Nicht relevante Spalten sind in der Ansicht ausgeblendet.

müsste ggf. noch angepasst werden

Option Explicit

Private Dateiliste() As String 'Sammelbehälter
Private Dateizähler As Long  'Zähler dazu
'
Sub Dateinzusammenführen()
Dim oDateisatz As Object
Dim Verbindung As String
Dim Abfrage As String
Dim x As Long, y As Long, z As Long 'Zählvariable - Datei, Spalte, Zeile
Dim Ziel As Range 'Zielzelle
Dim v As Long 'Abfrage
'
'****************************************************************************
Rem Variante mit Abfrage Überschreiben, sonst diese Zeile auskommentieren
v = MsgBox("Vorhandene Werte überschreiben ?", vbYesNo, "Sicherheitsabfrage")
'****************************************************************************
Dateizähler = 0
MappenSuche ActiveWorkbook.Path, "*.xl*" 'Aufruf Unterprozedur
If Dateizähler = 0 Then GoTo errorsearch 'keine Dateien
'
Abfrage = "SELECT * FROM " & "[Tabelle1$]"  'Tabellenname ist konstant !
'
On Error GoTo errorquerry
'
For x = 0 To Dateizähler - 1  'Liste abarbeiten
  Set Ziel = [A2] 'wegen Überschrift
  Verbindung = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=" & Dateiliste(1, x) & ";" & _
    "Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"""
'
  Set oDateisatz = CreateObject("ADODB.Recordset")
  oDateisatz.Open Abfrage, Verbindung, 0, 1, 1  'Tabelle einlesen
'
  If Not oDateisatz.EOF Then  'Tabelle auswerten
    z = -1
    With oDateisatz
      Do While Not .EOF
        z = z + 1
        For y = 1 To .Fields.Count - 1
          If VarType(.Fields(y)) > 1 Then 'keine leeren
          '************************************************
          Rem mit Sicherheitsabfrage, sonst auskommentieren
            If Ziel.Offset(z, y).Value <> "" Then
              If v = 6 Then Ziel.Offset(z, y) = .Fields(y)
            Else
              Ziel.Offset(z, y) = .Fields(y)
            End If
          '************************************************
          
          '********************************************
          Rem ohne Sicherheitsabfrage, dafür einsetzen
            'Ziel.Offset(z, y) = .Fields(y)
          '********************************************
          End If
        Next y
        .movenext
      Loop
    End With
'
  End If
  Set oDateisatz = Nothing
'
Next x
'
On Error GoTo 0
Exit Sub
errorsearch:
MsgBox "Fehler bei Dateisuche"
Exit Sub
errorquerry:
MsgBox "Fehler bei Abfrage"
End Sub
Private Sub MappenSuche(imOrdner As String, Suchbegriff As String)
    Dim oOrdner As Object
    Dim oDatei As Object
    Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    For Each oDatei In oFSO.GetFolder(imOrdner).Files
        If oDatei.Name Like Suchbegriff Then
          If InStr(oDatei.Name, ActiveWorkbook.Name) = 0 Then
            ReDim Preserve Dateiliste(0 To 1, Dateizähler)
            Dateiliste(0, Dateizähler) = oDatei.Name
            Dateiliste(1, Dateizähler) = oDatei.Path
            Dateizähler = Dateizähler + 1
          End If
        End If
    Next
    For Each oOrdner In oFSO.GetFolder(imOrdner).Subfolders
        MappenSuche imOrdner & "\" & oOrdner.Name, Suchbegriff
    Next
End Sub