Listenabgleich => Makro beschleunigen

Servus zusammen,
von unserem Vertrieb bekomme ich regelmäßig eine Liste mit zu produzierenden Bauteilen. Um unsere Planung auf der jeweiligen Produktionslinie durchführen zu können möchte ich mir daher die Komplettliste über ein Workbook_Open-Makro in einzelne Tabellenblätter aufteilen lassen (je nach Produktlinie). Das funktioniert zwar schon, allerdings dauert der Makroablauf gefühlte 5 Min, allein schon bei der Beispieldatei im Anhang. Bei der richtigen Liste mit ca. 24 Spalten stürzt mir Excel immer rund um Zeile 1000 ab :(
Die Liste ist open end, also es werden noch deutlich mehr als insgesamt 1500 Zeilen.
Der Abgleich mit der bestehenden PL-Liste ist erforderlich, damit nicht aus versehen irgendwelche Duplikate reinwandern. In den PL-Blättern tragen meine Kollegen in dahinterliegenden Spalten ihre Arbeitsfortschritte ein. Die PL-Blätter dürfen sich also lediglich ergänzen, aber nicht überschreiben!
Bitte, liebe Profis, seht euch bitte mal das Makro "Zuteilung" im Modul 2 an. Wie kann ich es schneller machen, oder gesamthaft optimieren? Und wie verhindere ich einen Absturz von Excel?
https://www.herber.de/bbs/user/107898.xlsm
Danke und Grüße

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Zuteilung() Dim Ordernummer As Long Dim Baureihe As String Dim lz As Long, lz1 As Long, i As Long lz = ThisWorkbook.Sheets("Liste_Vertrieb").Cells(Rows.Count, 2).End(xlUp).Row '' Einträge den Tabellenreitern der Derivate zuordnen For i = 2 To lz With Sheets("Liste_Vertrieb") Ordernummer = .Cells(i, 4).Value Baureihe = .Cells(i, 2).Value End With With ThisWorkbook.Sheets(Baureihe) If IsError(Application.Match(Ordernummer, .Columns(4), 0)) Then lz1 = .Cells(Rows.Count, 2).End(xlUp).Row + 1 Sheets("Liste_Vertrieb").Cells(i, 1).Resize(, 4).Copy Destination:=.Cells(lz1, 1) End If End With Next i End Sub

Sub ff() Dim wsV As Worksheet Dim wsPL As Worksheet Dim c As Range Dim firstAddress As String Dim lz As Long Set wsV = ThisWorkbook.Worksheets("Liste_Vertrieb") For Each wsPL In ThisWorkbook.Worksheets If (Not wsPL.Name = wsV.Name And wsPL.Name Like "PL*") Then With wsV.Columns("B") Set c = .Find(wsPL.Name, LookIn:=xlValues) If Not c Is Nothing Then firstAddress = c.Address Do lz = wsPL.Cells(1048576, 1).End(xlUp).Row + 1 wsPL.Range(wsPL.Cells(lz, 1), wsPL.Cells(lz, 4)) = wsV.Range("A" & c.Row & ":D" & c.Row). _ Value Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address firstAddress End If End With End If Next End Sub

Beliebteste Forumthreads (12 Monate)

Listenabgleich => Makro beschleunigen

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread