Excel VBA-Code optimieren

[flado]

Hallo zusammen

hab folgenden Code geschrieben, siehe angehängte Datei, es werden zwei Tabellen verglichen und die fehlenden Daten in Tabelle 1 geschrieben, soweit funktioniert der Code, aber bei größeren Daten (ca. 10000 Zeilen) läuft der Code extrem lang.
Nun bin ich auf der Suche ob mir jemand Helfen kann diesen Code zu optimieren, wäre für die Hilfe sehr Dankbar.

Gruß

Flado

[Steffl]

Hallo,

in deiner Beispieldatei ist in der Tabelle2 ein Auftragswert doppelt vorhanden. Die unterscheiden sich nur durch die weiteren Spalten. Was soll in solchen Fällen geschehen?

Code:

Sub prcTreffer()
   Dim lngC As Long
   Dim rngTreffer As Range
   Dim strAdresse As String
    
   With Worksheets("Tabelle2")
      For lngC = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
         Set rngTreffer = Worksheets("Tabelle1").Columns(1).Find(.Cells(lngC, 1), LookIn:=xlValues, lookat:=xlWhole)
         If Not rngTreffer Is Nothing Then
            strAdresse = rngTreffer.Address
            Do
               If IsEmpty(rngTreffer.Offset(, 2).Value) Then .Cells(lngC, 2).Resize(, 2).Copy rngTreffer.Offset(, 2)
               Set rngTreffer = Worksheets("Tabelle1").Columns(1).FindNext(rngTreffer)
            Loop While strAdresse <> rngTreffer.Address
         End If
      Next lngC
   End With
End Sub

[flado]

Hallo

das war mein Fehler Auftragsnummer können in der Liste die wo ich bearbeite nicht vorkommen, muss deswegen nicht berücksichtig werden.

Danke für den Code werden ich dann mal Testen.

Gruß

Michael

[Steffl]

Hallo Michael,

ich interpretiere mal das der Satz

doppelte Auftragsnummer können in der Liste die wo ich bearbeite nicht vorkommen

hätte lauten sollen. Da brauche ich dann nicht mehr die zusätzlichen Abfragen zu machen und kürze den Code ein wenig.

Code:

Sub prcTreffer()
   Dim lngC As Long
   Dim rngTreffer As Range
    
   With Worksheets("Tabelle2")
      For lngC = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
         Set rngTreffer = Worksheets("Tabelle1").Columns(1).Find(.Cells(lngC, 1), LookIn:=xlValues, lookat:=xlWhole)
         If Not rngTreffer Is Nothing Then
            .Cells(lngC, 2).Resize(, 2).Copy rngTreffer.Offset(, 2)
         End If
      Next lngC
   End With
End Sub