Zellen prüfen und Status eintragen

[Der Steuerfuzzi]

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

[steve1da]

Zur Info...
https://www.ms-office-forum.net/forum/sh...p?t=375500