Hallo zusammen,
ich habe vor rund 6 Wochen das erste mal meine Nase in ein Buch zu VBA für Excel gesteckt und konnte es inzwischen auch mal anwenden.
Dummerweise läuft das Ganze recht langsam ab. Bei meinen ersten Versuchen (die funktionierten) dauerte die Ausführung rund 16 Minuten.
Inzwischen bin ich bei knapp 9 Minuten (auf einer älteren Excel Version und einem langsamen PC *hab ich den Eindruck*).
Dateien:
Makro.xlsm - Mit dem Makro drin und einem Knopf, der das Ganze ausführt.
Hier werden dann die beiden Dateien geöffnet (Teil1.xls und Teil2.xls). Diese Dateien beinhalten zusammen rund 70.000-80.000 Zeilen (daher auch die Trennung). Die Excel-Version mit der ich "dabei" Arbeite packt nut 65xxx.
Ich durchlaufe nun Spalte 5 (E) und schaue mir die "Kundennummer" an. In der Mitte füge ich noch "00" ein (nebenbei). Hierbei wird der gefundene Wert entweder in einer neu erstellten Arbeitsmappe in Spalte A angefügt oder - wenn die Kundennummer schon existiert - der Wert in Spalten 2-5 entsprechend aufsummiert (in welche Spalte es geht, wird in Spalte H der Teil-Dateien ausgelesen).
Nebenbei gibt es noch Ausschlussfaktoren in Spalte 2 der Teil-Dateien. Hierbei wird die Zeile dann ignoriert.
Der Code funktioniert so wie er soll. Es geht mir hier 1.) um einen sauberen Code (wie gesagt bin ich Anfänger) und 2.) um die Geschwindigkeit.
Ein Beispiel (keine Originaldateien, nur Beispielhaft nachgebaut) findet ihr hier: http://www.fileuploadx.de/928268
Hat jemand Tipps für mich?
Viele Grüße
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
Pfad(1) = Workbooks("Makros.xlsm").Path & "\"
Pfad(2) = Workbooks("Makros.xlsm").Path & "\"
DateiName(1) = "Teil1.xls"
DateiName(2) = "Teil2.xls"
Set nWB = Workbooks.Add
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"
For i = 1 To 2
Workbooks.Open Filename:=Pfad(i) & DateiName(i)
lz = Range("E:E").End(xlDown).Row
For z = 1 To lz - 1
If (Cells(z + 1, 2).Value <> "Ausschluss1") And (Cells(z + 1, 2).Value <> "Ausschluss2") And (Cells(z + 1, 2).Value <> "Ausschluss3") And (Cells(z + 1, 2).Value <> "Ausschluss4") Then
Select Case Cells(z + 1, 8).Value
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(Cells(z + 1, 5), 1, 4) & "00" & Mid(Cells(z + 1, 5), 5, 8))
If Cells(z + 1, 5).Value = Cells(z, 5).Value Then
nWB.Sheets(1).Range("A:A").Find(What:=nW).Offset(0, offs).Value = _
nWB.Sheets(1).Range("A:A").Find(What:=nW).Offset(0, offs).Value _
+ Cells(z + 1, 13)
Else
efz = nWB.Sheets(1).Range("A65536").End(xlUp).Offset(1, 0).Row
nWB.Sheets(1).Cells(efz, 1).Value = nW
nWB.Sheets(1).Cells(efz, offs + 1).Value = _
nWB.Sheets(1).Cells(efz, offs +1) + 1).Value + _
Cells(z + 1, 13)
End If
End If
Next z
Workbooks(DateiName(i)).Close (False)
Next i
nWB.SaveAs Filename:=Workbooks("Makros.xlsm").Path & "\" & Format(Date, "YYYYMMDD") & "_Ergebnis.xls"
nWB.Close (False)
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
|