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

decadence

Well-known Member
Joined
Oct 9, 2015
Messages
516
Office Version
365, 2016, 2013, 2010, 2007
Platform
Windows
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
IPN
Customer Part
APPLE01_123456
APPLE01_987654

<tbody>
</tbody>

Example 2
VPN
Customer Part
BANANA_654321
BANANA_139756

<tbody>
</tbody>


Code:
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
 
Last edited:

Some videos you may like

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.

Watch MrExcel Video

Forum statistics

Threads
1,099,788
Messages
5,470,789
Members
406,722
Latest member
Fcolombo

This Week's Hot Topics

Top