Check values seperated by comma, if matches copy cells

[dervish65]

Hi!

Since I'm new to VBA I'm looking for a code to solve the following problem:

There are two Worksheets in the attached Excel-File called "Inventory" and "Location".

As soon as there's an entry in row D of the sheet "Location", the value of the 12 left characters of the entry should be compared with the data of row A in sheet "Inventory". If it matches an inventory-number, the rows A, B, C and E in the line of the compared numer in sheet "Location" should be copied to the rows E to H in sheet "Inventory". This should also work for possibly more then one entries per cell, seperated by comma in row D of sheet "Location".

I hope i could explain my needs for everyone to understand, though english is not my native language.

thanks
dervish65

[dervish65]

Problem solved!

Thanx to Carsten from Bremen!

Here's his perfectly working Code for my Inventory-List:

Sub SearchString()
' http://www.vb-paradise.de/programmieren/visual-basic-for-applications-vba/69901-vba-zelle-vergleichen-und-bei-bedingung-kopieren-finden/
' CaBe
' Version 1.0
' 13.06.2013

    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("Inventory")
    Set Sheet2 = Worksheets("Location")
   
    LastRow = FindLastRow(Sheet1, "A")
    For lRow = 3 To LastRow
        ' Die nachfolgende Codezeile würde funktionieren,
        ' wenn alle Inv.Nr. als Text vorlägen
        'SearchString = CStr(Left(Sheet1.Cells(lRow, "A"), 12))
       
        ' Alternativ wird der Zellinhalt Zeichen für Zeichen
        ' in einen String gewandelt
        SearchString = CStr(Left(Sheet1.Cells(lRow, "A"), 1))
        For i = 2 To 13
            ' Falls Komma enthalten, keine String-Umwandlung
            If Not Mid(Sheet1.Cells(lRow, "A"), i, 1) = "," Then
                SearchString = SearchString & Mid(Sheet1.Cells(lRow, "A"), i, 1)
            End If
        Next i
        ' Stringlänge auf 12 reduzieren (wegen Kommabehandlung war Länge = 13)
        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

Regards
dervish65