Option Explicit
Private Dateiliste() As String
Private Dateizähler As Long
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
Dim Ziel As Range
Dim v As Long
Rem Variante mit Abfrage Überschreiben, sonst diese Zeile auskommentieren
v = MsgBox("Vorhandene Werte überschreiben ?", vbYesNo, "Sicherheitsabfrage")
Dateizähler = 0
MappenSuche ActiveWorkbook.Path, "*.xl*"
If Dateizähler = 0 Then GoTo errorsearch
Abfrage = "SELECT * FROM " & "[Tabelle1$]"
On Error GoTo errorquerry
For x = 0 To Dateizähler - 1
Set Ziel = [A2]
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
If Not oDateisatz.EOF Then
z = -1
With oDateisatz
Do While Not .EOF
z = z + 1
For y = 1 To .Fields.Count - 1
If VarType(.Fields(y)) > 1 Then
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
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