VBA Search Value from other sheet and return data

[tbxor]

Test.xlsm
	A	B	C	D	E	F	G
1	12/18/2022	16:31:51	Host WWID	Guest Badge ID	Guest Name	Contact Number	Badge No
2	12/18/2022	16:04:47	12120088	13465789	John	1234567	KK5-1
3	12/18/2022	16:05:01	12128800	13245646	Doe	1324658	KK5-2
4	12/18/2022	16:05:45	12167778	13244587	Lucy	1456738	KK5-3
5	12/18/2022	16:05:54	12167778	56478974	Aaron	1897654
6	12/18/2022	16:05:59	12778888	13264894	Joseph	1348795
7	12/18/2022	16:06:05	12778888	14654987	Isaac	1354879
Dec22

Test.xlsm
	A	B	C
1	No	Guest Badge ID	Origin
2	1	13465789	KK5
3	2	13245646	KK5
4	3	13244587	KK5
5	4	56478974	KK5
6	1	13264894	KD2
7	2	14654987	KD2
BadgeList

There's multiple guest badge origin. KK5 and KD2. All of them listed in badge list sheet. I need to lookup the value of Guest Badge ID, 5th column in Dec22 sheet. Get the data from Badge List sheet and set the value of Badge No column in Dec22 sheet to be a combination of Origin and Badge No as shown in G2 until G4.

 

[Alex Blakenburg]

See if this works for you.

Sub LookupBadgeID_dic()

    Dim shtAct As Worksheet, shtBadge As Worksheet
    Dim rngActResult As Range, rngActID As Range, rngBadge As Range
    Dim arrBadge As Variant, arrActID As Variant
    Dim LRowAct As Long, LRowBadge As Long
    Dim dictBadge As Object, dictKey As String
    Dim i As Long
    
    Set shtAct = ActiveSheet
    Set shtBadge = Worksheets("BadgeList")
    
    With shtAct
        LRowAct = .Range("A" & Rows.Count).End(xlUp).Row
        Set rngActID = .Range(.Cells(2, "D"), .Cells(LRowAct, "D"))
        Set rngActResult = .Range(.Cells(2, "G"), .Cells(LRowAct, "G"))
        arrActID = rngActID.Value2
        ReDim Preserve arrActID(1 To UBound(arrActID), 1 To 2)
    End With
    
    With shtBadge
        LRowBadge = .Range("A" & Rows.Count).End(xlUp).Row
        Set rngBadge = .Range(.Cells(2, "A"), .Cells(LRowBadge, "C"))
        arrBadge = rngBadge.Value2
    End With
    
    Set dictBadge = CreateObject("Scripting.dictionary")
    
    ' Load badge lookup range into Dictionary
    For i = 1 To UBound(arrBadge)
        dictKey = arrBadge(i, 2)
        If Not dictBadge.exists(dictKey) Then
            dictBadge(dictKey) = i
        End If
    Next i
    
    ' For Lookup return value get values from Dictionary
    For i = 1 To UBound(arrActID)
        dictKey = arrActID(i, 1)
        If dictBadge.exists(dictKey) Then
            arrActID(i, 2) = arrBadge(dictBadge(dictKey), 3) & "-" & arrBadge(dictBadge(dictKey), 1)
        End If
    Next i
    
    rngActResult.Value2 = Application.Index(arrActID, 0, 2)

End Sub

 

[tbxor]

See if this works for you.

Sub LookupBadgeID_dic()

    Dim shtAct As Worksheet, shtBadge As Worksheet
    Dim rngActResult As Range, rngActID As Range, rngBadge As Range
    Dim arrBadge As Variant, arrActID As Variant
    Dim LRowAct As Long, LRowBadge As Long
    Dim dictBadge As Object, dictKey As String
    Dim i As Long
  
    Set shtAct = ActiveSheet
    Set shtBadge = Worksheets("BadgeList")
  
    With shtAct
        LRowAct = .Range("A" & Rows.Count).End(xlUp).Row
        Set rngActID = .Range(.Cells(2, "D"), .Cells(LRowAct, "D"))
        Set rngActResult = .Range(.Cells(2, "G"), .Cells(LRowAct, "G"))
        arrActID = rngActID.Value2
        ReDim Preserve arrActID(1 To UBound(arrActID), 1 To 2)
    End With
  
    With shtBadge
        LRowBadge = .Range("A" & Rows.Count).End(xlUp).Row
        Set rngBadge = .Range(.Cells(2, "A"), .Cells(LRowBadge, "C"))
        arrBadge = rngBadge.Value2
    End With
  
    Set dictBadge = CreateObject("Scripting.dictionary")
  
    ' Load badge lookup range into Dictionary
    For i = 1 To UBound(arrBadge)
        dictKey = arrBadge(i, 2)
        If Not dictBadge.exists(dictKey) Then
            dictBadge(dictKey) = i
        End If
    Next i
  
    ' For Lookup return value get values from Dictionary
    For i = 1 To UBound(arrActID)
        dictKey = arrActID(i, 1)
        If dictBadge.exists(dictKey) Then
            arrActID(i, 2) = arrBadge(dictBadge(dictKey), 3) & "-" & arrBadge(dictBadge(dictKey), 1)
        End If
    Next i
  
    rngActResult.Value2 = Application.Index(arrActID, 0, 2)

End Sub

Can you fiddle a code that checks for a targeted cell change using Worksheet_Change target.column? for example, when I edit the value of D2, it will trigger an xlookup

 

[Alex Blakenburg]

Try this:-

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim rngChg As Range, rCell As Range
    Dim shtBadge As Worksheet
    Dim rngBadge As Range
    Dim LRowBadge As Long
    
    Set rngChg = Intersect(Target, Columns("D"))

    If Not rngChg Is Nothing Then
        Application.EnableEvents = False
        Set shtBadge = Worksheets("BadgeList")
        With shtBadge
            LRowBadge = .Range("A" & Rows.Count).End(xlUp).Row
            Set rngBadge = .Range(.Cells(2, "A"), .Cells(LRowBadge, "C"))
        End With
    
        For Each rCell In rngChg
             rCell.Offset(, 3).Value2 = Application.XLookup(rCell, rngBadge.Columns(2), rngBadge.Columns(3)) & "-" & _
                                                Application.XLookup(rCell, rngBadge.Columns(2), rngBadge.Columns(1))
        Next rCell
        Application.EnableEvents = True
    End If

End Sub

 

[tbxor]

Try this:-

Private Sub Worksheet_Change(ByVal Target As Range)
   
    Dim rngChg As Range, rCell As Range
    Dim shtBadge As Worksheet
    Dim rngBadge As Range
    Dim LRowBadge As Long
   
    Set rngChg = Intersect(Target, Columns("D"))

    If Not rngChg Is Nothing Then
        Application.EnableEvents = False
        Set shtBadge = Worksheets("BadgeList")
        With shtBadge
            LRowBadge = .Range("A" & Rows.Count).End(xlUp).Row
            Set rngBadge = .Range(.Cells(2, "A"), .Cells(LRowBadge, "C"))
        End With
   
        For Each rCell In rngChg
             rCell.Offset(, 3).Value2 = Application.XLookup(rCell, rngBadge.Columns(2), rngBadge.Columns(3)) & "-" & _
                                                Application.XLookup(rCell, rngBadge.Columns(2), rngBadge.Columns(1))
        Next rCell
        Application.EnableEvents = True
    End If

End Sub

niiiiiicceeeee. thaannnk youuuu!

 

[Alex Blakenburg]

No problem. Glad we got it working for you.