Falls ich dein Code richtig interpretiert habe und das Makro noch läuft, sollte es dies so jetzt deutlich schneller tun:
Option Explicit
Sub Zusammenfuegen()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Dim DateiName(1 To 2) As String
Dim Pfad(1 To 2) As String
Dim i As Long
Dim nWB As Workbook
Dim lz As Long, efz As Long, z As Long 'lz=letzte Zeile; efz=erste freie Zeile
Dim offs As Long 'offset
Dim nW As String
Dim AV, rng As Range, R&, lastR&, nSh As Worksheet, Stat As Object
Set Stat = Application.StatusBar
Pfad(1) = Workbooks("Makros.xlsm").Path & "\"
Pfad(2) = Workbooks("Makros.xlsm").Path & "\"
DateiName(1) = "Teil1.xls"
DateiName(2) = "Teil2.xls"
Set nWB = Workbooks.Add
Set nSh = nWB.Sheets(1)
With nSh
.Cells(1, 1).Value = "Ü1"
.Cells(1, 2).Value = "Ü2"
.Cells(1, 3).Value = "Ü3"
.Cells(1, 4).Value = "Ü4"
.Cells(1, 5).Value = "Ü5"
End With
efz = nSh.Range("A65536").End(xlUp).Row + 1
For i = 1 To 2
Workbooks.Open Filename:=Pfad(i) & DateiName(i)
lz = Cells(Rows.Count, 5).End(xlUp).Row
Set rng = Range(Cells(1, 1), Cells(lz, 5))
AV = rng.Value
For z = 1 To lz
If (AV(z + 1, 2) <> "Ausschluss1") And (AV(z + 1, 2) <> "Ausschluss2") And (AV(z + 1, 2) <> "Ausschluss3") And (AV(z + 1, 2) <> "Ausschluss4") Then
Select Case AV(z + 1, 8)
Case Is = "Ü2"
offs = 1
Case Is = "Ü3"
offs = 2
Case Is = "Ü4"
offs = 3
Case Is = "Ü5"
offs = 4
End Select
nW = Val(Mid(AV(z + 1, 5), 1, 4) & "00" & Mid(AV(z + 1, 5), 5, 8))
If AV(z + 1, 5) = AV(z, 5) Then
With nSh.Range("A:A").Find(What:=nW).Offset(0, offs)
.Value = .Value + AV(z + 1, 13)
End With
Else
With nSh
.Cells(efz, 1).Value = nW
.Cells(efz, offs + 1).Value = _
.Cells(efz, offs + 1).Value + AV(z + 1, 13)
efz = efz + 1
End With
End If
End If
'status bar
If R = lastR + 100 Or R = lz Then
Stat = "Zeile: " & R & "/" & lz
lastR = R
End If
Next z
lastR = 0
Workbooks(DateiName(i)).Close (False)
Stat = "Files: " & i & "/" & 2
Next i
With nWB
.SaveAs Filename:=Workbooks("Makros.xlsm").Path & "\" & Format(Date, "YYYYMMDD") & "_Ergebnis.xls"
'wenn "makros.xlsm" DIESES workbook ist kannst du auch "thisworkbook" verwenden
.Close (False)
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
MsgBox "Datei unter " & Workbooks("Makros.xlsm").Path & "\" & Format(Date, "YYYYMMDD") & "_Ergebnis.xls gespeichert."
End Sub
Mann kann jetzt die Ausgabe Daten auch noch in ein Array schreiben und dieses dann dynamisch erweitern und transponiert in die neue Arbeitsmappe schreiben...
|