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 BestellungWareneingang()
Dim lz As Long, n As Long, x As Long, m As Long, y As Long
Dim arrBest(), arrEing(), arrBestEing(), arrFirma1(), arrFirma2(), arrFirma3(), arrFirma4(), arrFirma5()
Dim objRng As Range
Dim objWks_B As Worksheet
Dim objWks_W As Worksheet
Dim objWks_BW As Worksheet
Dim objWks_1 As Worksheet
Dim objWks_2 As Worksheet
Dim objWks_3 As Worksheet
Dim objWks_4 As Worksheet
Dim objWks_5 As Worksheet
Set objWks_1 = ThisWorkbook.Worksheets("Firma1")
With objWks_1
lz = .Cells(Rows.Count, "A").End(xlUp).Row
Set objRng = .Range(.Cells(1, 1), .Cells(lz, 1))
arrFirma1 = objRng.Value
End With
Set objWks_Firma2 = ThisWorkbook.Worksheets("Firma2")
With objWks_Firma2
lz = .Cells(Rows.Count, "A").End(xlUp).Row
Set objRng = .Range(.Cells(1, 1), .Cells(lz, 1))
arrFirma2 = objRng.Value
End With
Set objWks_Firma3 = ThisWorkbook.Worksheets("Firma3")
With objWks_Firma3
lz = .Cells(Rows.Count, "A").End(xlUp).Row
Set objRng = .Range(.Cells(1, 1), .Cells(lz, 1))
arrFirma3 = objRng.Value
End With
Set objWks_Firma4 = ThisWorkbook.Worksheets("Firma4")
With objWks_Firma4
lz = .Cells(Rows.Count, "A").End(xlUp).Row
Set objRng = .Range(.Cells(1, 1), .Cells(lz, 1))
arrFirma4 = objRng.Value
End With
Set objWks_Firma5 = ThisWorkbook.Worksheets("Firma5")
With objWks_Firma5
lz = .Cells(Rows.Count, "A").End(xlUp).Row
Set objRng = .Range(.Cells(1, 1), .Cells(lz, 1))
arrFirma5 = objRng.Value
End With
Set objWks_BW = ThisWorkbook.Worksheets("Bestellung+Wareneingang")
m = 2
With objWks_BW
lz = .Cells(Rows.Count, "A").End(xlUp).Row
Set objRng = .Range(.Cells(2, 1), .Cells(lz, 1))
arrBestEing = objRng.Value
End With
' ** 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, 3))
'Werte der Zellen in Array schreiben
arrBest = objRng.Value
End With
' **********************************************
' ** Lieferung ********************************
Set objWks_W = ThisWorkbook.Worksheets("Wareneingang")
With objWks_W
lz = .Cells(Rows.Count, "A").End(xlUp).Row
Set objRng = .Range(.Cells(2, 1), .Cells(lz, 3))
arrEing = objRng.Value
End With
' **********************************************
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
objWks_B.Cells(x + 1, 9) = "Ja"
objWks_W.Cells(x + 1, 9) = "Ja"
'Kopiervorgang von 'Bestellungen'und 'Wareneingang' in 'Bestellung+Wareneingang'
With objWks_BW
.Range(.Cells(m, 1), .Cells(m, 2)).Value = _
objWks_B.Range(objWks_B.Cells(n + 1, 1), objWks_B.Cells(n + 1, 2)).Value
objWks_BW.Cells(m, 3).Value = objWks_W.Cells(n + 1, 8).Value
.Range(.Cells(m, 4), .Cells(m, 5)).Value = _
objWks_B.Range(objWks_B.Cells(n + 1, 3), objWks_B.Cells(n + 1, 4)).Value
objWks_BW.Cells(m, 6).Value = objWks_B.Cells(n + 1, 6).Value
objWks_BW.Cells(m, 7).Value = objWks_B.Cells(n + 1, 5).Value
objWks_BW.Cells(m, 8).Value = objWks_W.Cells(n + 1, 5).Value
.Range(.Cells(m, 9), .Cells(m, 10)).Value = _
objWks_B.Range(objWks_B.Cells(n + 1, 7), objWks_B.Cells(n + 1, 8)).Value
objWks_BW.Cells(m, 11).Value = objWks_W.Cells(n + 1, 7).Value
m = m + 1
End With
Exit For
End If
Next x
Next n
Application.ScreenUpdating = True
Application.ScreenUpdating = False
For m = 1 To UBound(arrBestEing)
For y = 1 To UBound(arrFirma1)
If arrBestEing(m, 1) = arrFirma1(y, 1) Then
'Kopiervorgang von 'Bestellung+Wareneingang'in 'Firma1'
With objWks_BW.Cells(y + 2, 2).Value = objWks_1.Cells(m + 1, 1).Value
End With
Exit For
End If
Next y
Next m
Application.ScreenUpdating = True
End Sub
Hab den 1 Teil etwas abgeändert (nicht ausschneiden, sondern nur in die neue Tabelle kopieren)
Jetzt hab ich den 2 Teil versucht umzusetzen (erstmal ohne Sverweis) aber auch das funktioniert schon nicht:D ich kann das einfach nicht
|