Daten aus mehreren Excel-Dateien zusammenfügen
18.11.2013 12:32:19
Joana
mein Problem wurde hier zwar schon in ähnlicher Form ausführlich diskutiert, jedoch so 100% Lösungsansätze habe ich nicht gefunden. Zu meinem Problem:
Ich habe einen Ordner, in dem sich an die 250 Excel-Dateien befinden. Die Excel-Dateien sind alle identisch. Also sie bestehen alle aus einem Arbeitsblatt und alle sind im Spaltenumfang gleich, nur die Zeilen können nach unten varieren (max. 5 bis 10 Zeilen mehr). Ich möchte jetzt gerne aus diesen vielen Dateien von Spalte A bis Spalte AQ die Werte in nur eine Excel-Tabelle ziehen (ohne hinterlegte Formeln und ohne irgendeine Formatierung) und diese vielen Daten sollen bzw. können auch untereinander geschrieben werden. Allerdings sollen die Werte erst ab Zeile 14 übernommen werden.
Ich habe aus dem Internet einen VBA-Code gefunden, der eigentlich super funktioniert, jedoch die Werte schon ab Zeile 1 übernimmt. Es muss aber unbedingt Zeile 14 sein. Ich bekomme es einfach nicht hin, hab auch schon versucht ihn umzuschreiben - aber nix. Füge mal den Code, so wie ich ihn aus dem Netz hab, mit an. Vielleicht hat ja jemand ne Idee. Würde mich über ne hilfreiche Antwort sehr freuen, denn ich bin dem Heulen nahe. Vielen Dank schonmal im Vorraus ;-)
Sub Zusammenführen()
Dim i As Long
Dim sPfad As String
Dim sDatei As String
Dim vFileToOpen As Variant
Dim lngLZ As Long
Dim blnÜberschrift As Boolean
Dim iCalc As Integer
vFileToOpen = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , , , True)
If Not IsArray(vFileToOpen) Then Exit Sub
iCalc = Application.Calculation
On Error GoTo ENDE:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
For i = 1 To UBound(vFileToOpen)
sDatei = Dir(vFileToOpen(i))
sPfad = Left(vFileToOpen(i), InStr(vFileToOpen(i), sDatei) - 1)
With Tabelle1.Range("A1")
.Formula = "=LOOKUP(2,1/('" & sPfad & "[" & sDatei & "]Tabelle1'!$A:$A""""),ROW('" _
_
& sPfad & "\[" & sDatei & "]Tabelle1'!$A:$A))"
lngLZ = .Value
End With
With Tabelle1
If blnÜberschrift Then
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ - 1, 43).Formula = _
"='" & sPfad & "[" & sDatei & "]Tabelle1'!A2"
Else
blnÜberschrift = True
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ, 43).Formula = _
"='" & sPfad & "[" & sDatei & "]Tabelle1'!A1"
End If
End With
Next
With Tabelle1.UsedRange
.Copy
.PasteSpecial xlPasteValues
.Rows(1).Delete
End With
ENDE:
Application.EnableEvents = True
Application.Calculation = iCalc
Application.ScreenUpdating = True
If Err Then MsgBox Err.Description, , "Fehler: " & Err
End Sub