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
|