Sub SearchString()
Dim Sheet1 As Worksheet
Dim Sheet2 As Worksheet
Dim LastRow As Long
Dim lRow As Long, i As Integer
Dim SearchString As String
Dim Found As Range
Set Sheet1 = Worksheets("Inventar")
Set Sheet2 = Worksheets("Standort")
LastRow = FindLastRow(Sheet1, "A")
For lRow = 3 To LastRow
SearchString = CStr(Left(Sheet1.Cells(lRow, "A"), 1))
For i = 2 To 13
If Not Mid(Sheet1.Cells(lRow, "A"), i, 1) = "," Then
SearchString = SearchString & Mid(Sheet1.Cells(lRow, "A"), i, 1)
End If
Next i
SearchString = Left(SearchString, 12)
Set Found = FindString(SearchString, Sheet2.Columns("D"), , xlPart)
If Not (Found Is Nothing) Then
Sheet1.Cells(lRow, "E") = Sheet2.Cells(Found.Row, "A")
Sheet1.Cells(lRow, "F") = Sheet2.Cells(Found.Row, "B")
Sheet1.Cells(lRow, "G") = Sheet2.Cells(Found.Row, "C")
Sheet1.Cells(lRow, "H") = Sheet2.Cells(Found.Row, "E")
End If
Next lRow
Set Sheet1 = Nothing
Set Sheet2 = Nothing
End Sub
Public Function FindLastRow(ByVal WS As Worksheet, ColumnLetter As String) As Long
FindLastRow = WS.Range(ColumnLetter & "65536").End(xlUp).Row
End Function
Function FindString(Find_Item As Variant, Search_Range As Range, _
Optional LookIn As XlFindLookIn = xlValues, _
Optional LookAt As XlLookAt = xlPart, _
Optional MatchCase As Boolean = False) As Range
Dim c As Range
Set FindString = Nothing
With Search_Range
Set FindString = .Find( _
What:=Find_Item, _
LookIn:=LookIn, _
LookAt:=LookAt, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=MatchCase, _
SearchFormat:=False)
End With
End Function