VBA set sheet based on sheet Array and Part of Cell Value Array

[decadence]

Hi, My Code below is so I can get the cell value from the lookup workbook and add it to the Active Workbook if both cells values are the same

What I would like to do is match part of a cell value to a sheet name and set that sheet as the look up sheet.

Each part of a cell value will vary but will always have the same prefix before an underscore in every cell of a Range, so I would like to use the underscore to find the prefix. Each Sheet will have the a prefix as it's name in the lookup workbook.

So what I want to do is match the cell prefix from the Active Sheet to the sheet name prefix from the lookup workbook and set that sheet prefix as the lookup sheet if the cell prefix is found so I can get the value from the prefix sheet and add it to the Active Sheet.


Example 1
[TABLE="class: grid, width: 250"]
<tbody>[TR]
[TD]IPN
[/TD]
[TD]Customer Part
[/TD]
[/TR]
[TR]
[TD]APPLE01_123456
[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]APPLE01_987654
[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Example 2
[TABLE="class: grid, width: 250"]
<tbody>[TR]
[TD]VPN
[/TD]
[TD]Customer Part
[/TD]
[/TR]
[TR]
[TD]BANANA_654321
[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]BANANA_139756
[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Public Sub PartLookup()
'
    Dim WB1 As Workbook, WB2 As Workbook
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim mywb As String
    Dim LR As Long
    Dim c As Range, x As Range, Rng As Range, i As Range

    Application.ScreenUpdating = False
    For Each i In Range("A1:Z2")
    Select Case i.Value2
    
    Case "IPN", "Part", "Part Number", "VPN"

            If Not Rng Is Nothing Then
                Set Rng = Union(Rng, i)
            Else
                Set Rng = i
            End If
            End Select
        Next
    If Rng Is Nothing Then Exit Sub

    mywb = "Part Description 2018.xlsx"
    Workbooks.Open FileName:="C:\Users\Decadence\Desktop\Part Description 2018.xlsx"
    ActiveWindow.Visible = False

    Set WB1 = ActiveWorkbook
    Set WB2 = Workbooks("Part Description 2018.xlsx")
    Set sh1 = WB1.ActiveSheet
    Set sh2 = WB2.Sheets("Customer") '<---- Note: Need to make into an Array

    LR = sh1.Cells(Rows.Count, 2).End(xlUp).Row
        If Not Rng Is Nothing Then
            Set Rng = Rng.Resize(Cells(Rows.Count, Rng.Column).End(xlUp).Row)
        End If

    For Each c In Rng
        Set x = sh2.Range("A:A").Find(c.Value, , xlValues, xlWhole)
            If Not x Is Nothing Then
            c.Offset(0, 1).Value = x.Offset(0, 1).Value
        End If
    Next
    Set x = Nothing
    Workbooks(mywb).Close False
    Application.ScreenUpdating = True
End Sub