Makro braucht ewig ..
14.04.2022 11:33:43
Fred
ich nutze seit langen ein Makro, welches mir Daten von einem Sheet Unikate zum anderen Sheet Tagesliste zuordnet. Zufrieden bin ich nicht mit der Ablaufzeit des Makros bei vielen Datensätzen.
Beispiel:
DS Unikate : 300
DS Tagesliste: 16000
Dauer: über 1,5 Std.
Das muss doch auch schneller abgearbeitet werden!
Hier der Code
Dim lngZeile As Long
Dim lngSpalteMax As Long
Dim lngZeileMax As Long
Dim lngSpalte As Long
Dim lngZeileMax2 As Long
Dim VarDat As Variant
Dim i As Long
Dim sQuellSpalte As String
Dim sZielSpalte As String
Dim lngQuellZeile As Long
Dim lngQuellSpalte As Long
Dim lngZielZeile As Long
Dim lngZielSpalte As Long
Application.ScreenUpdating = False
LZ_UnikateClear2 = ThisWorkbook.Sheets("Tagesliste").Cells(Rows.Count, 1).End(xlUp).Row
Sheets("Tagesliste").Range("Y8:Z" & LZ_UnikateClear2).ClearContents
With Sheets("Unikate")
'Ermittel die letzte beschriebene Zeile in Spalte A "Unikate" und speichere den Wert in Variable lngZeileMax
lngZeileMax = .Range("A" & .Rows.Count).End(xlUp).Row
'Ermittel die Anzahl der beschriebenen Spalten in "unikate" und speichere den Wert in Variable lngSpalteMax
lngSpalteMax = .UsedRange.SpecialCells(xlCellTypeLastCell).Column ' minus 1 weil letzte Spalte eine Hilfsspalte ist
'Ermittel die letzte beschriebene Zelle in Spalte A "Tagesliste" und speichere den Wert in Variable lngZeileMax2
lngZeileMax2 = Sheets("Tagesliste").Range("A" & .Rows.Count).End(xlUp).Row
'Schleife zum durchsuchen der Zeilen von Zeile 5 beginnend bis zur letzten beschriebenen Zeile in Spalte A
For lngZeile = 5 To lngZeileMax
'Definiere Suchbereich der Schleife
VarDat = Sheets("Tagesliste").Range("A2:A" & lngZeileMax2)
'Pruefe nun Zeile fuer Zeile im definierten Suchbereich VarDat
For i = 1 To UBound(VarDat)
'Wenn der Wert in der Zeile "Live" = Wert in der Zeile "import"
If .Range("A" & lngZeile).Value = VarDat(i, 1) Then
'dann starte neue Schleife und beginne mit Uebertrag der Daten in die Zielzeile und Zielspalte
For lngSpalte = 21 To (lngSpalteMax + 0) ' kopiert ab Spalte
lngQuellZeile = lngZeile
lngQuellSpalte = lngSpalte
lngZielZeile = i + 1
lngZielSpalte = lngQuellSpalte + 4 ' fügt ein ab Spalte
'Übertrage Daten in die Spalten
Sheets("Tagesliste").Cells(lngZielZeile, lngZielSpalte).Value = .Cells(lngQuellZeile, lngQuellSpalte).Value
Next lngSpalte
End If
Next i
Next lngZeile
End With
Application.CutCopyMode = True
relevantSheet Unikate mit formatierter Tabelle tb_Unikate
Beginn A4 (Titel)
zu vergleichende Werte: in Spalte A
zu übermittelnde Werte: in Spalten U:V
Sheet Tagesliste mit formatierter Tabelle tb_Tagesliste
Beginn A7 (Titel)
zu vergleichende Werte: in Spalte A
einzufügende Werte: in Spalten U:V
Kann mir bitte ein Experte dieses Makro in Hinsicht auf die "Abarbeitungszeit" optimieren oder einen ganz anderen "Makroablauf" schreiben?
viele Grüße
Fred