Lookup and Join inquiry

[rn119]

I need to join a comma delimited list to a list that has the corresponding naming conventions. For example...

Table A - Starting from Cell A2

45,745

209,65,35

45,112,N60

<tbody>
</tbody>

Table B - Starting from Cell A2 (ID) & B2 (Name)

45 Exam One 209 Test Two 112 Protocol 209 Demo 35 Prod 65 Proof of Control 745 Modality N60 Culture <tbody> </tbody> My results in another column should be: Exam One, Modality Demo, Proof of Control, Prod Exam One, Protocol, Culture <tbody> </tbody>

<tbody>
</tbody>

Can this be done?

 

[mumps]

Start by formatting column A in Table A as 'Text'. The macro assumes that Table A is in Sheet1 and Table B is in Sheet2. Change the sheet names (in red) to suit your needs. The result will be place in column C of Sheet1.

Sub LookupAndJoin()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, rng As Range, i As Long, spl As Variant, fnd As Range, x As Long: x = 2
    Set desWS = Sheets("[COLOR="#FF0000"]Sheet1[/COLOR]")
    Set srcWS = Sheets("[COLOR="#FF0000"]Sheet2[/COLOR]")
    LastRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For Each rng In desWS.Range("A2:A" & LastRow)
        spl = Split(rng, ",")
        For i = LBound(spl) To UBound(spl)
            Set fnd = srcWS.Range("A:A").Find(spl(i), LookIn:=xlValues, lookat:=xlPart)
            If Not fnd Is Nothing Then
                If desWS.Cells(x, 3) = "" Then
                    desWS.Cells(x, 3) = fnd.Offset(, 1)
                Else
                    desWS.Cells(x, 3) = desWS.Cells(x, 3) & ", " & fnd.Offset(, 1)
                End If
            End If
        Next i
        x = x + 1
    Next rng
    Application.ScreenUpdating = True
End Sub

 

[DanteAmor]

I show you another approach, maybe it can be faster.

Sub Join_Name()
  Dim a As Variant, b As Variant, c() As Variant, dict As Object, i As Long, s As Variant
  a = Sheets("[COLOR=#ff0000]Tab1[/COLOR]").Range("[COLOR=#0000ff]A2[/COLOR]", Sheets("[COLOR=#ff0000]Tab1[/COLOR]").Range("[COLOR=#0000ff]A[/COLOR]" & Rows.Count).End(xlUp))
  b = Sheets("[COLOR=#ff0000]Tab2[/COLOR]").Range("[COLOR=#0000ff]A2[/COLOR]", Sheets("[COLOR=#ff0000]Tab2[/COLOR]").Range("[COLOR=#0000ff]B[/COLOR]" & Rows.Count).End(xlUp))
  Set dict = CreateObject("scripting.dictionary")
  For i = 1 To UBound(b)
    dict.Add CStr(b(i, 1)), b(i, 2)
  Next
  ReDim c(UBound(a) - 1)
  For i = 1 To UBound(a)
    For Each s In Split(a(i, 1), ",")
      If dict.Exists(Trim(s)) Then
        c(i - 1) = c(i - 1) & ", " & dict(Trim(s))
      End If
    Next
    c(i - 1) = Mid(c(i - 1), 3)
  Next
  Sheets("[COLOR=#ff0000]Tab1[/COLOR]").Range("[COLOR=#0000ff]B2[/COLOR]").Resize(UBound(a)).Value = Application.Transpose(c)
End Sub

Note:
In your example you have twice the 209:

209	Test Two
112	Protocol
209	Demo

<tbody>
</tbody>