Liste nach Werten einer zweiten Liste durchsuchen

Option Explicit
Option Compare Text

Const Sheet1 = "Liste1"         ' Tabellenname Liste 1  
Const Sheet2 = "Liste2"         ' Tabellenname Liste 2  

Const SpalteSuchen = "A"        ' Liste 2 Spalte Suchen  
Const SpalteValue = "I"         ' Liste 2 Spalte Wert  

Const TextSN = "Device S/N:"    ' Text mit Seriennummer  

Const Msg0 = "Seriennummer ? nicht gefunden!"  

Sub TestFindSerienNummer()
    Dim List1 As Worksheet, Found As Range, Token As Variant, C As Range, SN As String, EndLine As Long
    
    Set List1 = Sheets(Sheet1)
    
    EndLine = Cells(Rows.Count, SpalteSuchen).End(xlUp).Row
    
    For Each C In List1.Range(SpalteSuchen & "1:" & SpalteSuchen & EndLine)  
        If C Like "*" & TextSN & "*" Then  
            Token = Split(C, TextSN)
            
            If UBound(Token) = 1 Then
                SN = Trim(Token(1))
                
                If SN <> "" Then  
                    With Sheets(Sheet2)
                       .AutoFilterMode = False
                         
                        Set Found = .Columns(SpalteSuchen).Find(SN, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
                    
                        If Not Found Is Nothing Then
                             Token = Split(List1.Cells(C.Row - 4, SpalteSuchen), ":")  
                             
                             If UBound(Token) > 0 Then
                                .Cells(Found.Row, SpalteValue) = Trim(Token(UBound(Token)))
                            End If
                        Else
                            MsgBox Replace(Msg0, "?", SN), vbInformation, "Suchen..."  
                        End If
                    End With
                End If
            End If
        End If
    Next
End Sub

Option Explicit
Option Compare Text

Const Sheet1 = "Liste1"         ' Tabellenname Liste 1  
Const Sheet2 = "Liste2"         ' Tabellenname Liste 2  

Const SpalteSuchen = "A"        ' Liste 2 Spalte Suchen  
Const SpalteValue = "I"         ' Liste 2 Spalte Wert  

Const TextSN = "Device S/N:"    ' Text mit Seriennummer  

Const Msg0 = "Seriennummer ? nicht gefunden!"  

Sub TestFindSerienNummer()
    Dim List1 As Worksheet, Found As Range, Token As Variant, C As Range
    Dim SN As String, EndLine As Long, i As Long
    
    Set List1 = Sheets(Sheet1)
    
    EndLine = List1.Cells(List1.Rows.Count, SpalteSuchen).End(xlUp).Row
    
    For i = 1 To EndLine
        If i > EndLine Then Exit For
        If List1.Cells(i, "A") Like "empty*" Then  
            List1.Rows(i).Delete:  i = i - 1:  EndLine = EndLine - 1
        End If
    Next
    
    For Each C In List1.Range(SpalteSuchen & "1:" & SpalteSuchen & EndLine)  
        If C Like "*" & TextSN & "*" Then  
            Token = Split(C, TextSN)
            
            If UBound(Token) = 1 Then
                SN = Trim(Token(1))
                
                If SN <> "" Then  
                    With Sheets(Sheet2)
                       .AutoFilterMode = False
                         
                        Set Found = .Columns(SpalteSuchen).Find(SN, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
                    
                        If Not Found Is Nothing Then
                             Token = Split(List1.Cells(C.Row - 4, SpalteSuchen), ":")  
                             
                             If UBound(Token) > 0 Then
                                .Cells(Found.Row, SpalteValue) = Trim(Token(UBound(Token)))
                            End If
                        Else
                            MsgBox Replace(Msg0, "?", SN), vbInformation, "Suchen..."  
                        End If
                    End With
                End If
            End If
        End If
    Next
End Sub

                                With .Cells(Found.Row, SpalteValue)
                                    If IsEmpty(.Value) Then
                                        .Value = Trim(Token(UBound(Token)))
                                    Else
                                        .Value = .Value & " / " & Trim(Token(UBound(Token)))  
                                    End If
                                End With

Option Explicit
Option Compare Text

Const Sheet1 = "Liste1"                     'Tabellenname Liste 1  
Const Sheet2 = "Liste2"                     'Tabellenname Liste 2  

Const SpalteSuchen = "A"                    'Liste 2 Spalte Suchen  
Const SpalteValue = "I"                     'Liste 2 Spalte Wert  

Const TextSN = "*Device S/N:*"              'Text mit Seriennummer  
Const TextTY = "*End Supply Type:*"         'Text mit Type  

Const Msg0 = "Die Aktion wurde aufgrund eines Fehlers abgebrochen!"  
Const Msg1 = "Seriennummer ? nicht gefunden!"  

Sub FindSerienNummer3()
    Dim List1 As Worksheet, Token As Variant, SN() As String, TY() As String
    Dim Found As Range, C As Range, EndLine As Long, i As Long, x1 As Long, x2 As Long
    
    Set List1 = Sheets(Sheet1)
    
    EndLine = List1.Cells(List1.Rows.Count, SpalteSuchen).End(xlUp).Row
    
    For Each C In List1.Range(SpalteSuchen & "1:" & SpalteSuchen & EndLine)  
        If C Like TextSN Then
            Token = Split(C, ":")  
            ReDim Preserve SN(x1) As String: SN(x1) = Trim(Token(UBound(Token))):  x1 = x1 + 1
        ElseIf C Like TextTY Then
            Token = Split(C, ":")  
            ReDim Preserve TY(x2) As String: TY(x2) = Trim(Token(UBound(Token))):  x2 = x2 + 1
        End If
    Next
    
    If x1 = 0 Or x1 <> x2 Then MsgBox Msg0, vbExclamation, "Daten einlesen...": Exit Sub  

    With Sheets(Sheet2)
       .AutoFilterMode = False
    
        For i = 0 To UBound(SN)
            If SN(i) <> "" Then  
                Set Found = .Columns(SpalteSuchen).Find(SN(i), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
                        
                If Not Found Is Nothing Then
                    With .Cells(Found.Row, SpalteValue)
                        If IsEmpty(.Value) Then .Value = TY(i) Else .Value = .Value & " / " & TY(i)  
                    End With
                Else
                    MsgBox Replace(Msg1, "?", SN(i)), vbInformation, "Suchen..."  
                End If
            End If
        Next

       .Range("A1:K1").AutoFilter  
    End With
    
    MsgBox "Fertig!", vbInformation, "Meldung"  
End Sub