< 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
|