Makroausführung braucht zu lange
02.03.2023 13:35:03
Hens135
ich benötige eure Hilfe. Und zwar habe ich vor einigen Wochen hier ein super Makro erhalten, was meine Arbeitstabelle um Daten einer neuen Tabelle ergänzt und anhand eines Kriteriums die restlichen Spalten innerhalb der Zelle richtig wiedergibt.
Ich habe das Makro jetzt in meine Praxis umgesetzt, da wir hier aber von einigermaßen vielen Datensätzen sprechen (6000 Zeilen und 40 Spalten) benötigt das Makro etwa 3 31/2 Stunden bis es durchgelaufen ist.
Daher meine Fragen, ob jemand von euch Möglichkeit der Verschlankung des Makros sieht?
Ich habe dazu auch eine Beispieldatei hochgeladen. Allerdings ist die tatsächliche Datei deutlich größer.
https://www.herber.de/bbs/user/158093.xlsm
Sub Daten_uebertragen() Debug.Print Now Dim i As Long, Zeile As Long, letzteZeile As Long Dim Arbeitsmappe As Workbook Dim Datenbasis As Worksheet, Ziel As Worksheet Dim ZelleKD_NR As Range, Bereich As Range Dim iName As Integer, iTel As Integer, iNr As Integer, iOrt As Integer, _ iStrasse As Integer, iPLZ As Integer, iBranche As Integer, iKdNr As Integer Set Arbeitsmappe = ThisWorkbook Set Datenbasis = Arbeitsmappe.Worksheets("1. Update aus SAP") Set Ziel = Arbeitsmappe.Worksheets("Bestandstabelle") With Datenbasis For i = 1 To 8 Select Case .Cells(1, i) Case "Branchen_Art": iBranche = i Case "Firma_Name": iName = i Case "KD_NR": iKdNr = i Case "PLZ": iPLZ = i Case "Ort": iOrt = i Case "PHONE_NR": iTel = i Case "Straße": iStrasse = i Case "NR": iNr = i End Select Next i End With With Datenbasis letzteZeile = .Cells(Rows.Count, iKdNr).End(xlUp).Row Set Bereich = .Range(.Cells(2, iKdNr), .Cells(letzteZeile, iKdNr)) End With For i = 2 To Ziel.Range("C" & Rows.Count).End(xlUp).Row With Datenbasis Set ZelleKD_NR = Bereich.Find(Ziel.Range("C" & i).Value, LookIn:=xlValues, lookat:=xlWhole) If Not ZelleKD_NR Is Nothing Then Ziel.Range("A" & i).Value = .Cells(ZelleKD_NR.Row, iBranche).Value Ziel.Range("B" & i).Value = .Cells(ZelleKD_NR.Row, iName).Value Ziel.Range("D" & i).Value = .Cells(ZelleKD_NR.Row, iPLZ).Value Ziel.Range("E" & i).Value = .Cells(ZelleKD_NR.Row, iOrt).Value Ziel.Range("F" & i).Value = .Cells(ZelleKD_NR.Row, iStrasse).Value Ziel.Range("G" & i).Value = .Cells(ZelleKD_NR.Row, iNr).Value Ziel.Range("H" & i).Value = .Cells(ZelleKD_NR.Row, iTel).Value Set ZelleKD_NR = Nothing End If End With Next i Debug.Print Now End Sub
Danke vorab und liebe Grüße
Henrik