Match 2 columns of data based on common substring, with a fallback, using VBA?

Question

I have 2 columns of data: Item numbers and the image name for them (A and C):

Updated sample data:

If an image filename matches the item number, I want to match them in column B (empty) otherwise fall back to a default (if available).

Example: Iterate through column A & C, if image matches the item number, match, otherwise fall back to default. In my case, default would end with either -5.jpg, -4.jpg, 4-ROOM.jpg or 5-ROOM.jpg.

So the desired result (in column B above) would be everything except for LRL0547A-24.jpg would be matched with LRL0547-4-ROOM.jpg (because it's one of the fallbacks).

My code I've tried is here (I need another pair of eyeballs, mine are hurting):

Public Sub test()

Dim ws As Worksheet, arr(), r As Long, c As Long

Set ws = ThisWorkbook.Worksheets("Sheet1")

arr = ws.Range("A2:C" & ws.Cells(ws.Rows.Count, "C").End(xlUp).Row)

On Error Resume Next

For r = LBound(arr, 1) To UBound(arr, 1)
    For c = LBound(arr, 1) To UBound(arr, 1)
        Select Case True
        Case Right$(arr(c, 3), 9) = "4-ROOM.jpg" And Left$(arr(c, 3), Len(arr(c, 3)) - 9) = arr(r, 1)
            arr(r, 2) = arr(c, 3)
            Exit For
        Case Right$(arr(c, 3), 6) = "5-ROOM.jpg" And Left$(arr(c, 3), Len(arr(c, 3)) - 6) = arr(r, 1)
            arr(r, 2) = arr(c, 3)
            Exit For
        Case Right$(arr(c, 3), 6) = "-5.jpg" And Left$(arr(c, 3), Len(arr(c, 3)) - 6) = arr(r, 1)
            arr(r, 2) = arr(c, 3)
            Exit For
        End Select
    Next
Next

On Error GoTo 0

ws.Range("A2").Resize(UBound(arr, 1), UBound(arr, 2)) = arr

End Sub

Answer 1

Your inner loop needs to keep checking for an exact match, even if you already found a fallback.

Untested:

Public Sub test()

    Dim ws As Worksheet, arrSku, arrImg, r As Long, c As Long, itm, img, p As Long
    Dim rngSku As Range, rngImg As Range
    Dim exactMatch, fallBack, pm
    
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    Set rngSku = ws.Range("A2:B" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
    Set rngImg = ws.Range("C2:D" & ws.Cells(ws.Rows.Count, "C").End(xlUp).Row)
    
    arrSku = rngSku.Value 'each array has two "columns"
    arrImg = rngImg.Value
    
    For r = 1 To UBound(arrImg, 1) 'loop the images and remove any extension
        img = Trim(arrImg(r, 1))
        p = InStrRev(img, ".")
        If p > 0 Then img = Left(img, p - 1)
        arrImg(r, 2) = img 'caching the name with no extension back in the array
    Next r
    
    For r = 1 To UBound(arrSku, 1)
        itm = Trim(arrSku(r, 1))
        exactMatch = "" 'clear any previous matches
        fallBack = ""
        
        For c = 1 To UBound(arrImg, 1)
            img = arrImg(c, 2)            'checking against no-extension value
            If img = itm Then
                exactMatch = arrImg(c, 1) 'with extension
                Exit For 'no need to check further
            Else
                For Each pm In Array("4-ROOM", "5-ROOM", "-5")
                    If itm & pm = img Then
                        fallBack = arrImg(c, 1)
                        Exit For 'stop checking for fallbacks, but keep checking for exact match...
                    End If
                Next pm
            End If
        Next
        'did we make any kind of match?
        If Len(exactMatch) > 0 Then
            arrSku(r, 2) = exactMatch
        ElseIf Len(fallBack) > 0 Then
            arrSku(r, 2) = fallBack
        Else
            arrSku(r, 2) = ""
        End If
    Next
    
    rngSku.Value = arrSku 'put back data into A:B
End Sub

If this doesn't do what you want then please post some sample data in text format so I can test.