Hallo Andi

Geänderter Code. Jetzt wird nicht mehr kopiert, sondern aus beiden Tabellen ausgeschnitten und in eine neue eingefügt. Beim Ausschneiden bleiben leere Stellen. Diese Zeilen könnte man löschen, falls in der ganzen Zeile nichts mehr drin steht.

Option Explicit

' Vorgangsweise:
' Alle Daten der Tabelle 'Bestellung' von Saplte A bis H und bis zur letzten
' Daten in Spalte A werden in das Array 'arrBest' eingelesen. Analog alle
' Daten der Tabelle 'Wareneingang' von Saplte A bis C. Die ersten 3 Elemente
' in den beiden Array's werrden vergliche. Wenn gleich, dann wird kopiert.
' Einlesen und Array-Vergleich ist gegenüber anderen Methoden sehr schnell.

Sub Suchen_3_Kriterien()
Dim lz As Long, n As Long, x As Long
Dim zB As Long, zE As Long, zA As Long
Dim arrBest(), arrEing()
Dim objRng  As Range
Dim objWks_B  As Worksheet
Dim objWks_E  As Worksheet
Dim objWks_A As Worksheet


' **  Bestellung ********************************
'Tabelle mit Daten welche ins Array müssen
Set objWks_B = ThisWorkbook.Worksheets("Bestellungen")
  
With objWks_B
    ' letzte Datenzeile in Tabelle 'Bestellung' der Spalte A
    lz = .Cells(Rows.Count, "A").End(xlUp).Row
      
    'Zellen mit Daten welche ins Array müssen (Spalte A - H, 2 bis letzte Zeile)
    Set objRng = .Range(.Cells(2, 1), .Cells(lz, 8))
    
    'Werte der Zellen in Array schreiben
    arrBest = objRng.Value
End With
' **********************************************


' **  Lieferung ********************************
Set objWks_E = ThisWorkbook.Worksheets("Wareneingang")
With objWks_E
    lz = .Cells(Rows.Count, "A").End(xlUp).Row
    Set objRng = .Range(.Cells(2, 1), .Cells(lz, 3))
    arrEing = objRng.Value
End With
' **********************************************

' Tabelle 'Archiv' für Bestellung und Wareneingang
Set objWks_A = ThisWorkbook.Worksheets("Archiv")        ' Tabellennamen eventuell anpassen
lz = objWks_A.Cells(Rows.Count, "A").End(xlUp).Row      ' letzte Zeile mit Daten in 'Archiv'
zA = lz + 1                                             ' Zeile (leere) darunter

Application.ScreenUpdating = False
' Eigentliche Suche und vergleichen in den beiden Daten-Array's
For n = 1 To UBound(arrBest)
    For x = 1 To UBound(arrEing)
        If arrBest(n, 1) = arrEing(x, 1) And _
           arrBest(n, 2) = arrEing(x, 2) And _
           arrBest(n, 3) = arrEing(x, 3) Then
            
            'Ausschneiden aus 'Bestellung' und einfügen in 'Archiv'
            zB = n + 1  ' Werte beginnen in Tabelle 'Bestellung' ab Zeile 2
            objWks_B.Range("A" & zB & ":H" & zB).Cut Destination:= _
            objWks_A.Range("A" & zA & ":H" & zA)
            
             'Ausschneiden aus 'Wareneingang' und einfügen in 'Archiv'
            zE = x + 1  ' Werte beginnen in Tabelle 'Wareneingang' ab Zeile 2
            objWks_E.Range("A" & zE & ":H" & zE).Cut Destination:= _
            objWks_A.Range("I" & zA & ":P" & zA)
           
            zA = zA + 1 ' nächste leere Zeile in 'Archiv'
            Exit For
        End If
    Next x
Next n
Application.ScreenUpdating = True

End Sub

mfg, GraFri