22.06.2021, 15:10
Leider habe ich jetzt nicht so viel Zeit und Muße, den Code komplett zu überarbeiten. Ich habe mal den Vergleich der Daten in eine Function ausgelagert und den Abgleich des Status eingefügt. Schau mal, ob das so passt:
Code:
Option Explicit
Sub Daten_in_Overview()
Dim alleD As Variant, alleP As Variant, alleOverview As Variant, alleCategory As Variant
Dim leereZeile As Long, n As Long, x As Long
Dim vorhanden As Boolean
With Worksheets("Table_D")
alleD = .Range("A3:J" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With
With Worksheets("Table_P")
alleP = .Range("A3:J" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With
With Worksheets("Overview")
leereZeile = .Cells(Rows.Count, "A").End(xlUp).Row + 1
alleOverview = .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
alleCategory = .Range("A2:A" & leereZeile - 1).Value
For x = 1 To UBound(alleCategory)
If alleCategory(x, 1) = "D" Then
vorhanden = includes(alleOverview(x, 1), alleD)
Else
vorhanden = includes(alleOverview(x, 1), alleD)
End If
If vorhanden Then
.Cells(x + 1, "L") = ""
Else
.Cells(x + 1, "L") = "geschlossen"
End If
Next
vorhanden = False
For n = 1 To UBound(alleD, 1)
vorhanden = includes(alleD(n, 1), alleOverview)
If vorhanden = False Then
.Range("A" & leereZeile).Value = "D"
.Range("L" & leereZeile).Value = "neu"
For x = 1 To UBound(alleD, 2)
.Cells(leereZeile, x + 1) = alleD(n, x)
Next x
' oder einzeln ohne Schleife
'.Range("B" & leereZeile).Value = alleD(n, 1)
'.Range("C" & leereZeile).Value = alleD(n, 2)
' usw.
alleOverview = .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
leereZeile = leereZeile + 1
End If
vorhanden = False
Next n
For n = 1 To UBound(alleP, 1) - 1 ' -1: vor der letzte Zeile mit Expüortnachrichten aufhören
vorhanden = includes(alleP(n, 1), alleOverview)
If vorhanden = False Then
.Range("A" & leereZeile).Value = "P"
.Range("L" & leereZeile).Value = "neu"
For x = 1 To UBound(alleD, 2)
.Cells(leereZeile, x + 1) = alleP(n, x)
Next x
alleOverview = .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
leereZeile = leereZeile + 1
End If
vorhanden = False
Next n
End With
End Sub
Function includes(ByVal search As String, ByVal arr As Variant)
Dim i As Long
includes = False
For i = LBound(arr) To UBound(arr)
If search = arr(i, 1) Then
includes = True
Exit For
End If
Next
End Function