Excel VBA Find function - differentiate multiple results

Question

I have a Workbook with two Worksheets. On one worksheet, I have a column of comma separated values as text (electronic component references). E.g. C1 = "R1, R2, R3, ..., R125" ; C2 = "C1, C2, C3, ..." ; C3 = "TR1, TR2, TR3, ..." ; C4 = "IC1, IC2, IC3 ..."

I have created the code below to search column C on Sheet2 for a specific value (E.g. "R1"), and when it finds that value, get the part number from another column in same row. E.g. if it finds R1 in cell C12, it will return the part number from cell D12.

The code I've written below is working perfectly when column C contains only a unique list of comma separated values, but I'm having problems when there are duplicates. E.g. for the example above if R1 is in cell C1, and TR1 is in cell C3, then when I try to find R1 sometimes it only finds it in Cell C3, so returns the incorrect part number for TR1 instead of R1. I have the same problem with Cxx and ICxx references.

Somehow I need to modify the code so that if I am searching for only R1 and it is found in a particular cell, then I need to check if the R1 sub-string has a "T" immediately in front of it ("TR1"), and if so, keep searching.

I may also need to check if the found R1 has a comma immediately after it (i.e. "R1,"), so that I also don't get problems with e.g. R1 in one cell, and R11 in another cell with a different part number.

I don't really have a clue how to modify my code to go about this? Do I need to convert each cell where positive match is found into a string, and then do some kind of sub-string - within - string search?

Private Sub Pop_Rel_Click()

    Dim W1 As Workbook
    Set W1 = ActiveWorkbook       
    
    W1.Sheets("Sheet 1").Select
                
    'Select All non-empty cells in Column B (Ref-des) Row 11 onwards...
    
    ActiveSheet.Range("B11:B10000").SpecialCells(xlCellTypeConstants).Select
                                                       
    'Loop through ref-des selection...
    
    Dim cel As Range
    Dim selectedRange As Range
    Dim foundItem As Range
    Set selectedRange = Application.Selection

    For Each cel In selectedRange.Cells
        '...search for corresponding part number from sheet 2
        
        Set foundItem = W1.Sheets("Sheet 2").Range("C11:C1000").Find(What:=cel.Value, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        
        If foundItem Is Nothing Then
            Debug.Print cel.Address, cel.Value, "NOT FOUND"
        Else
            'find P/N from sheet 2...
            '...and insert into column C of sheet 1
            cel.Offset(0, 1) = foundItem.Offset(0, -1).Value
             
            Debug.Print cel.Address, cel.Value, foundItem.Address, foundItem.Offset(0, -1).Value, foundItem.Offset(0, 1).Value, foundItem.Offset(0, 2).Value
        End If

        'Debug.Print cel.Address, cel.Value,
    Next cel
                    
    'End loop
        
    MsgBox ("Populated in Worksheet 1:" & Chr(10) & "1. Part Numbers")

End Sub

Answer 1

If you find a match Split the string by comma into an array and check each element of the array for an exact match. If no match is found continue search with FindNext.

Option Explicit

Private Sub Pop_Rel_Click()
    
    Const HDR = 10 ' 10 rows header
    Dim Wb As Workbook, ws1 As Worksheet, ws2 As Worksheet
   
    Dim cel As Range, rngB As Range, rngSearch As Range, rngFound As Range
    Dim ar As Variant, s As String
    Dim i As Long, iLastRow As Long
    Dim sFirstFind As String, bMatch As Boolean

    Set Wb = ActiveWorkbook
    Set ws1 = Wb.Sheets("Sheet 1")
    Set ws2 = Wb.Sheets("Sheet 2")
                    
    'Select All non-empty cells in Column B (Ref-des) Row 11 onwards...
    iLastRow = ws1.Range("B" & Rows.Count).End(xlUp).Row
    Set rngB = ws1.Range("B" & HDR & ":B" & iLastRow).SpecialCells(xlCellTypeConstants)
   
    iLastRow = ws2.Range("C" & Rows.Count).End(xlUp).Row
    Set rngSearch = ws2.Range("C" & HDR & ":C" & iLastRow)

    For Each cel In rngB
        
        '...search for corresponding part number from sheet 2
        Set rngFound = rngSearch.Find(What:=cel.Value, _
           LookIn:=xlValues, LookAt:=xlPart, _
           SearchOrder:=xlByRows, _
           SearchDirection:=xlNext, _
           MatchCase:=False, SearchFormat:=False)
        
        bMatch = False
        If Not rngFound Is Nothing Then
               
            ' split string by comma into array
            bMatch = False
            sFirstFind = rngFound.Address
            
            Do
                ar = Split(rngFound.Value, ",")
                For i = 0 To UBound(ar)
                    If Trim(ar(i)) = cel Then
                     ' copy
                        cel.Offset(0, 1) = rngFound.Offset(0, 1).Value
                        bMatch = True
                        Exit For
                    End If
                Next
                Set rngFound = rngSearch.FindNext(rngFound)

            Loop While Not rngFound Is Nothing And bMatch = False _
                       And rngFound.Address <> sFirstFind
        End If
        ' no match
        If bMatch = False Then
            cel.Offset(0, 1) = "not found"
            Debug.Print "NOT FOUND", cel.Address, cel.Value
        End If

    Next cel
    MsgBox ("Populated in Worksheet 1:" & Chr(10) & "1. Part Numbers")
    
End Sub