Servus Sven,
einmal leise weinend davon abgesehen dass der Code wohl der langsamste seiner Art.
mit der Boolean ob mit / oder ohne Überschriften musste schon vor dem Aufruf der eigentlichen Sub die Bereichsgrößen festlegen.
PS: sag Stefan Bescheid, dass es so funktioniert
Option Explicit
Sub MitFormeln()
'leeren, wenn nötig
Sheets("Tabelle1").UsedRange.Offset(1).Clear
'die Quellen haben
Zusammenführen True 'Überschriften - oder auch nicht (False)
End Sub
Private Sub Zusammenführen(blnÜberschrift As Boolean)
Dim i As Long
Dim sPfad As String
Dim sDatei As String
Dim vFileToOpen As Variant
Dim lngLZ As Long
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("A2")
.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, 12).Formula = _
"='" & sPfad & "[" & sDatei & "]Tabelle1'!A2"
Else
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ, 12).Formula = _
"='" & sPfad & "[" & sDatei & "]Tabelle1'!A1"
End If
End With
'der Schmarrn bremst doch nur
'Call StatusBalken(Int((i / UBound(vFileToOpen)) * 100))
Next
With Tabelle1.UsedRange
.Copy
.PasteSpecial xlPasteValues
.Rows(2).Delete
End With
ENDE:
Application.EnableEvents = True
Application.Calculation = iCalc
Application.ScreenUpdating = True
If Err Then MsgBox Err.Description, , "Fehler: " & Err
End Sub
|