Hallo
das hab ich grad mal mit diversen Suchergebnissen dieses Forums runtergeschrieben.
Ich kommentiere es dir auch mal, damit du es nachvollziehen und ggf. anpassen kannst
Getestet hab ich nur EINE Tabelle je Datei. Ich wollte mir nicht noch Beispieldateien bauen.
Schau mal bitte, ob das deinem Problem hilft.
Grob gesagt: Dateien Öffnen, Bereich kopieren und in die Gesamtliste einfügen. Es wird
immer nur der gleiche Bereich kopiert. Zumindest hab ich so den ersten Post verstanden.
Gruß
--- Makro ---
Option Explicit
Sub DatenHolen()
Dim strPfad As String
Dim strDatei As String
Dim strExt As String
Dim rngBereich As Range
Dim lngTabMax As Long
Dim lngTab As Long
Dim lngZmax As Long
Dim WB As Workbook
Dim WS As Worksheet
Dim wsAusgabe As Worksheet
'Fehlerbehandlung: ist nur das notwendigste
On Error GoTo Aufräumen
'AusgabeTabelle anpassen
'eine neue Tabelle wird hinzugefügt
' Set wsAusgabe = ThisWorkbook.Worksheets.Add
'Fester Name
Set wsAusgabe = ThisWorkbook.Worksheets("Tabelle1")
Dim booAlleTabellen As Boolean
Dim arrDaten As Variant
Dim lngArrZmax As Long
Dim lngArrSmax As Long
'Pfadname anpassen
strPfad = "C:\temp\test\"
If Right(strPfad, 1) <> "\" Then strPfad = strPfad & "\"
'Dateiendung anpassen
strExt = "*.xls*"
'Bereich der zu durchsuchenden Zellen anpassen
Set rngBereich = Range("A1:C20")
'Anpassen: False = nur erste Tabelle; True = alle Tabellen
booAlleTabellen = False
If booAlleTabellen = False Then
lngTabMax = 1
Else
lngTabMax = WB.Worksheets.Count
End If
'Erste Datei suchen
strDatei = Dir(strPfad & strExt)
'Solange noch Dateien da sind
Do While Len(strDatei) > 0
'Datei öffnen
Set WB = Workbooks.Open(Filename:=strPfad & strDatei, ReadOnly:=True)
If Not WB Is Nothing Then
'Wenn Datei offen dann alle gewünschten
'Tabellen durchgehen (eine oder alle)
For lngTab = 1 To lngTabMax
'Tabelle auswählen
Set WS = WB.Worksheets(lngTab)
'Bereich in Variable schreiben
arrDaten = WS.Range(rngBereich.Address)
'Zielzeile suchen
lngZmax = wsAusgabe.Cells(2 ^ 16, 1).End(xlUp).Row + 1
'Arraygröße ermitteln
lngArrZmax = UBound(arrDaten, 1)
lngArrSmax = UBound(arrDaten, 2)
'Daten ausgeben
wsAusgabe.Range(wsAusgabe.Cells(lngZmax, 1), wsAusgabe.Cells(lngZmax + lngArrZmax - 1, lngArrSmax)) = arrDaten
Next lngTab
'Datei schliessen
WB.Close False
End If
'nächste Datei
strDatei = Dir()
Loop
Aufräumen:
'Notfalls Datei schliessen
On Error Resume Next
WB.Close False
On Error GoTo 0
'Variablen zurücksetzen
Set WB = Nothing
Set WS = Nothing
Set rngBereich = Nothing
Set wsAusgabe = Nothing
End Sub
|