Dateien zusammenziehen
17.08.2004 15:55:20
Richard
Habe folgendes Problem:
Ich möchte mehrere Dateien, die gleich aufgebaut sind, zusammenziehen, d.h. dass Excel sie einfach untereinander in eine Tabelle schreibt. Dabei sollen aber nur die Daten ab Zeile 2 übertragen werden; Zeile 1 beinhaltet jeweils die Spaltenüberschriften.
Hatte die Frage heute morgen schonmal im Forum und folgendes Makro (Danke hierfür) bekommen, dass aber nicht funktioniert (kann sein, dass ich beim Abschreiben einen Fehler gemacht habe, da die Vorlage eine jpeg-Datei war):
StandardModule: basMain
Sub Zusammenführen()
Dim wksTarget As Worksheet
Dim arr As Variant
Dim iCounter As Integer, iRows As Integer, iRowT As Integer
Dim sPath As String, sPattern As String
Application.ScreenUpdating = False
Workbooks.Add
Set wksTarget = Worksheets(1)
Range("A1") = "Datenimport"
Range("A1").Font.Bold = True
sPath = ThisWorkbook.Path
sPattern = "Test*.xls"
arr = arrAll(sPath, sPattern)
For iCounter = 1 To UBound(arr)
Workbooks.Open arr(iCounter)
iRows = Cells(Rows.Count, 3).End(x1Up).Row
iRowT = wksTarget.Cells(Rows.Count, 1).End(x1Up).Row + 2
With wks.Target.Cells(iRowT, 1)
.Value = arr(iCounter) & ":"
.Font.Bold = True
End With
iRowT = iRowT + 2
Rows("2:" & iRows).Copy wksTarget.Cells(iRowT, 1)
Application.DisplayAlerts = False
ActiveWorkbook.Close savechanges:=False
Application.DisplayAlerts = True
Next iCounter
Columns.AutoFit
End Sub
Function arrAll(sPath As String, sPattern As String) As Variant
Dim arr()
Dim iCounter As Integer
Dim sFile As String
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
sFile = Dir(sPath & sPattern)
Do While sFile <> ""
iCounter = iCounter + 1
ReDim Preserve arr(1 To iCounter)
arr(iCounter) = sFile
sFile = Dir()
Loop
arrAll = arr
End Function
Excel gibt als Fehlermeldung "Ausserhalb einer Prozedur ungültig" aus und markiert die Zeile StandardModule: basMain
Danke für Eure Hilfe!
Ciao,
Richard