Ca. vor einer Woche hat mir Matthias G. auf eine Anfrage im Forum hin nachfolgenden Code geschrieben, den ich noch etwas modifiziert habe. Dieser Makro (in der persönlichen Makrovorlage abgelegt) bewirkt folgendes:
1)
im aktiven Worksheet der aktiven Datei (sagen wir sie heisse Aktiv.xls) werden sämtliche xls-Dateinamen des aktuellen Pfades aufgeführt (ausser der xls-Datei, die gerade aktiv ist).
2)
die entsprechenden Dateien werden eine nach der anderen geöffnet und aus der Tabelle GLOBAL in allen aufgelisteten Dateien enthalten wird abgefragt, welches der letzte Eintrag in Spalte B ist. Dieser Wert wird in ein Worksheet namens Daten der Datei Aktiv.xls eingetragen.
Das funktioniert so tadellos. Nun, die ursprüngliche Absicht war und das war wohl nicht genügend klar beschrieben dass bei allen aufgelisteten Dateien im Worksheet GLOBAL ermittelt wird, in welcher Zelle der Spalte B der letzte Eintrag ist und dass dann alle Zeilen bis dorthin kopiert werden und in die Datei Aktiv.xls Worksheet GLOBAL übernommen werden. Angenommen, es wären nur 2 Dateien aufgelistet, und in der ersten wären in der Spalte B Einträge bis Zeile 53, würde der Bereich 1:53 in die Datei Aktiv.xls, Worksheet Daten reinkopiert, ebenfalls in den Bereich 1:53. Wenn nun in der zweiten Datei in Spalte B Einträge bis Zeile 20 enthalten sind, würden diese kopiert und in die Datei Aktiv.xls, Worksheet Daten in den Bereich 54:73 hineinkopiert.
Kann mir jemand sagen, wie ich die Funktion, vgl. ganz unten so abändere, dass nicht nur der Inhalt der letzte Zeile von Spalte ermittelt und übertragen (wird, sondern der ganze Bereich?
Wäre super!
Danke, Peter
Sub Dateien()
Const TabName = "GLOBAL" 'Blattname der Dateien
Const TabZiel = "Daten" ' Blatt in dem die Daten ankommen sollen
Dim strVerz As String
Dim strDatei As String
Dim lngZ As Long, i As Long, lr As Long
Dim WBAktiv As Workbook
Dim ShTab As Worksheet
Dim WB As Workbook
Set WBAktiv = ActiveWorkbook
Set ShTab = ActiveSheet
strVerz = ActiveWorkbook.Path & "\" 'Backslash am Ende nicht vergessen!
ShTab.Columns(1).ClearContents
Application.ScreenUpdating = False
'Verzeichnis auslesen
strDatei = Dir(strVerz & "*.xls")
'Debug.Print strDatei
Do Until strDatei = ""
If UCase(strVerz & strDatei) UCase(ActiveWorkbook.FullName) Then
lngZ = lngZ + 1
ShTab.Cells(lngZ, 1) = strDatei
End If
strDatei = Dir()
Loop
'Dateien nacheinander öffnen
For i = 1 To lngZ
Set WB = Workbooks.Open(Filename:=strVerz & ShTab.Cells(i, 1))
'letzte beschriebene Spalte ermitteln:
lr = LastRow(WB.Worksheets(TabName), 1)
'Wenn Spalte nicht leer dann...
If lr > 0 Then
'...Wert in Blatt [TabZiel] eintragen
WBAktiv.Sheets(TabZiel).Cells(i, 1) = WB.Worksheets(TabName).Cells(lr, 2)
End If
'Mappe (ohne speichern) schließen
WB.Close False
Next i
Application.ScreenUpdating = True
End Sub
'ermittelt letzte beschriebene Zelle von [Sh] in Spalte [col]
Function LastRow(sh As Worksheet, col As Integer) As Long
Dim rng As Range
Set rng = sh.Cells(sh.Rows.Count, col)
If rng.Value = "" Then
Set rng = rng.End(xlUp)
If rng = "" Then LastRow = 0: Exit Function
End If
LastRow = rng.Row
End Function