Suche und Vergleich erweitern

Option Explicit
Sub collectData()
Dim objLog As Worksheet, objGes As Worksheet, objSch As Worksheet, objFind As Range
Dim lngRow As Long, lngMax As Long, lngIndex As Long, lngN As Long, lngI As Long
Dim varRet As Variant, varOutput() As Variant
Dim strComp1 As String, strComp2 As String, strFirst As String
Dim bolFound As Boolean
'Objectvariablen zuweisen
Set objGes = Worksheets("Gesamtliste")
Set objLog = Worksheets("LogImport")
Set objSch = Worksheets("Schrottliste")
'Gesamtliste leeren
objGes.Cells.Clear
With objLog
'Anzahl der Zeilen in LogImport ermitteln
lngMax = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)
'Ausgabearray dimensionieren
ReDim varOutput(1 To 50000, 1 To 20)
'Zeilen durchlaufen
For lngRow = 2 To lngMax
'Barcode in Schrottliste suchen
varRet = Application.Match(.Cells(lngRow, 2), objSch.Columns(1), 0)
'Wenn Barcode NICHT gefunden, dann
If Not IsNumeric(varRet) Then
'R-Tabellen durchlaufen
For lngN = 1 To 5
'Gefundenvariable auf False setzen
bolFound = False
'Suchvariablen reseten
Set objFind = Nothing
strFirst = ""
'Barcode in R-Sheet suchen
Set objFind = Sheets("R" & lngN).Columns(2).Find(What:=.Cells(lngRow, 2), _
LookAt:=xlWhole, LookIn:=xlValues, MatchCase:=False, SearchFormat:=False)
'Wenn gefunden, dann
If Not objFind Is Nothing Then
'Adresse des ersten Treffers merken
strFirst = objFind.Address
'Gefunden auf True setzen
bolFound = True
'Suchschleife
Do
'Vergleichsstring aus LogImport
strComp1 = .Range("C" & lngRow) & .Range("D" & lngRow) & .Range("F" & lngRow)
'Vergleichsstring aus R-Sheet
strComp2 = Sheets("R" & lngN).Range("G" & objFind.Row) & _
Sheets("R" & lngN).Range("J" & objFind.Row) & _
Sheets("R" & lngN).Range("K" & objFind.Row)
'Wenn beide Vergleichsstrings ident, dann
If strComp1 = strComp2 Then
lngIndex = lngIndex + 1
If lngIndex > 50000 Then Exit For
'Daten in Ausgabearray schreiben
For lngI = 1 To 20
If lngI  objFind.Address
End If
'Wenn in einem R-Sheet gefunden, dann Schleife verlassen
If bolFound Then Exit For
Next
End If
Next
End With
'Wenn Daten im Ausgabearray
If lngIndex > 0 Then
With objGes
'Daten in Gesamtliste ab Zeile 2 schreiben
.Cells(2, 1).Resize(lngIndex, 20) = varOutput
'Überschriften setzen mit Formatierung
.Range("A1:L1").Value = Worksheets("R1").Range("A1:L1").Value
.Range("M1:T1").Value = objLog.Range("G1:N1").Value
.Rows(1).Font.Bold = True
.Columns("A:A").ColumnWidth = 7.43
.Columns("B:B").ColumnWidth = 13.71
.Columns("C:C").ColumnWidth = 8.29
.Columns("D:D").ColumnWidth = 14.43
.Columns("E:E").ColumnWidth = 22.14
.Columns("F:F").ColumnWidth = 6.57
.Columns("G:G").ColumnWidth = 7.43
.Columns("H:H").ColumnWidth = 8.14
.Columns("I:I").ColumnWidth = 9.14
.Columns("J:J").ColumnWidth = 3.43
.Columns("K:K").ColumnWidth = 10.43
.Columns("L:L").ColumnWidth = 7.86
.Columns("M:M").ColumnWidth = 10.29
.Columns("N:N").ColumnWidth = 8.29
.Columns("O:O").ColumnWidth = 9.86
.Columns("P:P").ColumnWidth = 10.57
.Columns("Q:Q").ColumnWidth = 10
.Columns("R:R").ColumnWidth = 10.71
.Columns("S:S").ColumnWidth = 5.43
.Columns("T:T").ColumnWidth = 7.29
End With
End If
'Variablen löschen
Set objLog = Nothing
Set objGes = Nothing
Set objSch = Nothing
Set objFind = Nothing
End Sub