Sub Stücklisten_vergleichen_neu()
Dim lzA As Long, lzH As Long
Dim Adr As String, Edr As String
Dim ZelleC As Range, ZelleJ As Range
Dim rFindC As Range, rFindJ As Range
Dim BlockC As String, BlockJ As String
Dim k As Integer 'Anzahl "+C.."
Dim Arry1(50, 2) As Variant 'Spalte C
Dim Arry2(50, 2) As Variant 'Spalte I
Dim a As Integer, j As Integer
Dim n1 As Integer, n2 As Integer
'On Error GoTo Fehler
With ThisWorkbook.Worksheets("Auswertung")
lzA = .Cells(Rows.Count, 1).End(xlUp).Row 'Anzahl Zeilen in Spalte A ermitteln
lzH = .Cells(Rows.Count, 8).End(xlUp).Row 'Anzahl Zeilen in Spalte H ermitteln
Application.ScreenUpdating = False
'Stückliste 1: Range Adressen ermitteln
Adr = "C7": n1 = 1 'Adresse in Array laden
For a = 4 To lzA
If InStr(.Cells(a, 2), "+C" & n1 + 1) Then
Edr = Cells(a - 1, 3).Address(0, 0)
Arry1(n1, 1) = CStr(Adr & ":" & Edr) 'Abschnitt in Array laden
Arry1(n1, 2) = "+C" & n1: n1 = n1 + 1 'Name Zentrale (z.B. +C1) in Array laden, n1 um 1 erhöhen
Adr = Cells(a + 1, 3).Address(0, 0)
End If
Next a
'letzter Block in der Stückliste
Edr = Cells(lzA, 3).Address(0, 0)
Arry1(n1, 1) = CStr(Adr & ":" & Edr)
Arry1(n1, 2) = "+C" & n1:
'Stückliste 2: Range Adressen ermitteln
Adr = "J7": n2 = 1 'Adresse in Array laden
For j = 4 To lzH
If InStr(.Cells(j, 9), "+C" & n2 + 1) Then
Edr = Cells(j - 1, 10).Address(0, 0)
Arry2(n2, 1) = CStr(Adr & ":" & Edr)
Arry2(n2, 2) = "+C" & n2: n2 = n2 + 1
Adr = Cells(j + 1, 10).Address(0, 0)
End If
Next j
'letzter Block in der Stückliste
Edr = Cells(lzH, 10).Address(0, 0)
Arry2(n2, 1) = CStr(Adr & ":" & Edr)
Arry2(n2, 2) = "+C" & n2:
'Abbruch wenn n1 n2 ist (Anzahl ^C in beiden Listen)
If n1 n2 Then MsgBox "Anzahl '+C' unterschiedlich - Abbruch": Exit Sub
'Stückliste 2: "+C2" auswerten und Zellen löschen
'übereinstimmende Zeilen löschen, OHNE Delete!!
For k = 1 To n1
BlockC = Arry1(k, 1) 'Range Adresse C laden
BlockJ = Arry2(k, 1) 'Range Adresse J laden
'Spalte J mit Spalte C vergleichen
For Each ZelleJ In Range(BlockJ)
Set rFindC = Range(BlockC).Find(What:=ZelleJ, After:=Range(BlockC).Cells(1, 1), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlColumns, _
SearchDirection:=xlNext, MatchCase:=False)
If Not rFindC Is Nothing Then
If ZelleJ.Offset(0, -1) = rFindC.Offset(0, -1) Then
Cells(ZelleJ.Row, 8).Resize(1, 6) = Empty 'Zeile H löschen
Cells(rFindC.Row, 1).Resize(1, 6) = Empty 'Zeile A löschen
Else
ZelleJ.Interior.ColorIndex = 7
End If
Else 'rfind Is Nothing
ZelleJ.Interior.ColorIndex = 7
End If
Next ZelleJ
'Spalte C mit Spalte J vergleichen
For Each ZelleC In Range(BlockC)
Set rFindJ = Range(BlockJ).Find(What:=ZelleC, After:=Range(BlockJ).Cells(1, 1), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlColumns, _
SearchDirection:=xlNext, MatchCase:=False)
If Not rFindJ Is Nothing Then
If ZelleC.Offset(0, -1) = rFindJ.Offset(0, -1) Then
Cells(ZelleC.Row, 1).Resize(1, 6) = Empty 'Zeile H löschen
Cells(rFindJ.Row, 8).Resize(1, 6) = Empty 'Zeile A löschen
Else
ZelleC.Interior.ColorIndex = 7
End If
Else 'rfind Is Nothing
ZelleC.Interior.ColorIndex = 7
End If
Next ZelleC
Next k 'Stückliste Auswertung Ende
'Löchroutinen mit Rückwaerts Step
For j = lzA To 5 Step -1
If InStr(Cells(j, 2), "+C") Then '"+C" überspringen
ElseIf Cells(j, 3).Value = Empty Then
Cells(j, 1).Resize(1, 6).Delete shift:=xlUp
End If
Next j
For j = lzH To 5 Step -1
If InStr(Cells(j, 9), "+C") Then '"+C" überspringen
ElseIf Cells(j, 10).Value = Empty Then
Cells(j, 8).Resize(1, 6).Delete shift:=xlUp
End If
Next j
End With
Exit Sub
Fehler: MsgBox "unerwarteter Fehler aufgetreten"
End Sub