Laufzeitenverbesserung für Abgleich
Andre
ich habe ein Makro gebastelt um von einer Quelle bestehende und neue Daten in eine Ziel Datei zu kopieren. Da ich noch nicht so fit bin, gibt es bestimmt kleine Stellen im Code die man verbessern kann um
die Laufzeit zu erhöhen. Da in meinen Sheets Daten von mehr als 15k Zeilen bestehen würde der Code
mehr als eine Stunde laufen.
Hat jemand eine Idee? Anbei der Code.
Gruss
Andre
Sub neu1()
Dim ZeilePreli As Range
Dim LZData As Range
Dim Zeile As Integer
Dim LZDataRow As Integer
Dim strfile As String
Dim Ziel, Quelle As Worksheet
Application.ScreenUpdating = False
strfile = Application.GetOpenFilename
Workbooks.Open Filename:=strfile
Set Ziel = Workbooks.Item(1).Worksheets("Data")
Set Quelle = Workbooks.Item(2).Worksheets("Data")
Zeile = 5
i = Workbooks.Item(1).Worksheets("Configuration").Cells(3, 2) ' Kriterium für die richtige _
Spalte
Do While Quelle.Cells(Zeile, 1) "" ' Solange Zeilen in input
IndexPreli = Quelle.Cells(Zeile, 1).Value ' ID aus Upload-Zeile zusammenbauen
Set ZeilePreli = Ziel.Range("A:A").Find(IndexPreli) ' In Data Ziel den Bezug für die ID _
_
_
_
_
_
suchen
If Not ZeilePreli Is Nothing Then ' In Data einen Bezug für ID aus input gefunden
Ziel.Cells(ZeilePreli.Row, 1).Interior.ColorIndex = 33 ' gefundene ID in Data _
markieren
'kopieren von actual figures
Ziel.Cells(ZeilePreli.Row, 23).Value = Quelle.Cells(Zeile, 23).Value
Ziel.Cells(ZeilePreli.Row, 24).Value = Quelle.Cells(Zeile, 24).Value
Ziel.Cells(ZeilePreli.Row, 25).Value = Quelle.Cells(Zeile, 25).Value
Ziel.Cells(ZeilePreli.Row, 31 + i).Value = Quelle.Cells(Zeile, 23).Value
Ziel.Cells(ZeilePreli.Row, 43 + i).Value = Quelle.Cells(Zeile, 24).Value
Ziel.Cells(ZeilePreli.Row, 107 + i).Value = Quelle.Cells(Zeile, 25).Value
'kopieren von LE figures
Ziel.Cells(ZeilePreli.Row, 26).Value = Quelle.Cells(Zeile, 26).Value
Ziel.Cells(ZeilePreli.Row, 27).Value = Quelle.Cells(Zeile, 27).Value
Ziel.Cells(ZeilePreli.Row, 28).Value = Quelle.Cells(Zeile, 28).Value
Ziel.Cells(ZeilePreli.Row, 43).Value = Quelle.Cells(Zeile, 26).Value
Ziel.Cells(ZeilePreli.Row, 55 + i).Value = Quelle.Cells(Zeile, 26).Value
Ziel.Cells(ZeilePreli.Row, 55).Value = Quelle.Cells(Zeile, 27).Value
Ziel.Cells(ZeilePreli.Row, 67 + i).Value = Quelle.Cells(Zeile, 27).Value
Ziel.Cells(ZeilePreli.Row, 119).Value = Quelle.Cells(Zeile, 28).Value
'kopieren von goal figures
Ziel.Cells(ZeilePreli.Row, 29).Value = Quelle.Cells(Zeile, 29).Value
Ziel.Cells(ZeilePreli.Row, 30).Value = Quelle.Cells(Zeile, 30).Value
Ziel.Cells(ZeilePreli.Row, 31).Value = Quelle.Cells(Zeile, 31).Value
Else ' Wenn in Ziel "Data" kein Bezug für die ID aus der gerade bearbeiteteten Zeile in _
Quelle "Data" gefunden werden kann
Workbooks.Item(2).Worksheets("Data").Activate
Range(Cells(Zeile, 1), Cells(Zeile, 31)).Copy ' Datenbereich aus input (Ctrl-C)
Set LZData = Ziel.Range("A5:A65536").Find("") ' Bezug auf erste Spalte Data ab A5
LZDataRow = LZData.Row ' Zeilennummer der ersten leere Zelle _
_
_
_
_
_
in Spalte A
' MsgBox LZDataRow
Workbooks.Item(1).Worksheets("Data").Activate
Cells(LZDataRow, 1).Select 'Spalte B der ersten leeren Zeile in _
Data
Selection.PasteSpecial Paste:=xlPasteValues ' Werte einfügen (ALT B,F,W)
'kopieren von actual figures
Ziel.Cells(LZData.Row, 31 + i).Value = Quelle.Cells(Zeile, 23).Value
Ziel.Cells(LZData.Row, 43 + i).Value = Quelle.Cells(Zeile, 24).Value
Ziel.Cells(LZData.Row, 107 + i).Value = Quelle.Cells(Zeile, 25).Value
'kopieren von LE figures
Ziel.Cells(LZData.Row, 43).Value = Quelle.Cells(Zeile, 26).Value
Ziel.Cells(LZData.Row, 55 + i).Value = Quelle.Cells(Zeile, 26).Value
Ziel.Cells(LZData.Row, 55).Value = Quelle.Cells(Zeile, 27).Value
Ziel.Cells(LZData.Row, 67 + i).Value = Quelle.Cells(Zeile, 27).Value
Ziel.Cells(LZData.Row, 119).Value = Quelle.Cells(Zeile, 28).Value
End If
Zeile = Zeile + 1 ' Nächste Zeile aus Quelle "data" bearbeiten
Loop
Application.ScreenUpdating = True
End Sub