Potential combination of LookUp and DeDupe to create multiple values in a single cell

[Bwambale]

Is it possible to look up a cell in one tab against another, find multiple instances of the number, then using a different column pick out unique value and combine the unique values into a cell on the original tab?

Hopefully the below helps clarify.

Table 1 contains the reference number i want to look up:

Reference Value
1
2
3
4

Table 2 contains the values i need for my final table against the reference number i am looking up. A reference can have multiple values

Reference Value
1 Car
2 Car
3 Car
4 Car
1 Car
1 Bus
1 Train
4 Bus

Table 3 shows the end result. For each reference number the values are merged into one cell allowing one line for each reference.

Reference Result
1 Car;Bus; Train
2 Car
3 Car
4 Car;Bus

Hopefully someone has done something similar to this before. If i need to provide any further clarity, please let me know.

Kris

[karedog]

Maybe :

Sub Test()
  Dim coll As New Collection, collDummy As New Collection, arr, i As Long, str1 As String, v1, v2

  arr = Sheet2.Range("A1").CurrentRegion.Value
  On Error Resume Next
     For i = 2 To UBound(arr, 1)
         Set collDummy = Nothing
         str1 = arr(i, 1)
         coll.Add key:=str1, Item:=collDummy
         coll(str1).Add key:=arr(i, 2), Item:=arr(i, 2)
     Next i
  On Error GoTo 0

  With Sheet1.Range("A1").CurrentRegion
    arr = .Value
    For i = 2 To UBound(arr, 1)
        arr(i, 2) = ""
        On Error Resume Next
           Set v1 = coll(CStr(arr(i, 1)))
           If Err.Number = 0 Then
              For Each v2 In v1
                  arr(i, 2) = arr(i, 2) & ";" & v2
              Next v2
              arr(i, 2) = Mid$(arr(i, 2), 2)
           End If
        On Error GoTo 0
    Next i
    .Value = arr
  End With
End Sub

[MickG]

Try this:-

Sub MG15Feb50
Dim Rng As Range, Dn As Range, n As Long, Dic As Object, c As Long
With Sheets("Sheet2")
Set Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
End With
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For Each Dn In Rng
    If Not Dic.exists(Dn.Value) Then
        Dic.Add Dn.Value, Dn.Offset(, 1).Value
    Else
        If Not InStr(Dic(Dn.Value), Dn.Offset(, 1).Value) > 0 Then
            Dic(Dn.Value) = Dic(Dn.Value) & ";" & Dn.Offset(, 1)
        End If
    End If
Next
With Sheets("Sheet1")
Set Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
End With
ReDim Ray(1 To Rng.Count + 1, 1 To 2)
Ray(1, 1) = "Reference": Ray(1, 2) = "Results"
c = 1
For Each Dn In Rng
    If Dic.exists(Dn.Value) Then
        c = c + 1
        Ray(c, 1) = Dn.Value: Ray(c, 2) = Dic(Dn.Value)
    End If
Next Dn
With Sheets("Sheet3").Range("A1").Resize(c, 2)
    .Value = Ray
    .Columns.AutoFit
    .Borders.Weight = 2
End With
End Sub

Regards Mick

[Bwambale]

Mick, that is exactly what I am looking for. Works a treat. Thank you!

[Bwambale]

Karedog, thanks very much for coming back to me. I appreciate it. I couldn't quite get your code to work...i had an issue with the "arr" line. Mick's code seems to have done the trick so i think i can leave it here. Thanks again for the help folks!

[karedog]

You are welcome.
But it run well on my file, could you test it ? Check the attachment.

[MickG]

You're welcome

[Bwambale]

Hey Mick,

Could you help with one more thing. Which part of the code would I need to alter to have the results displayed in column C instead of B? I am asking because I want to do something similar but collate info from a different field and list it in column C next to the data you helped with originally. Does that make sense?

[Bwambale]

Hey Karedog, just tested this now and yeah, that works exactly like it should. Thanks!!

[karedog]

You are welcome, thanks for the feedback.


Regards

[MickG]

My previous code shows the results in columns "A & B"
Change as below for various options:-

Next Dn
'Option 1 sheet3 starts column "C"
With Sheets("Sheet3").Range("C1").Resize(c, 2)
    
'Option 2, Activesheet column "C"
With Activesheet.Range("C1").Resize(c, 2)


.Value = Ray
    .Columns.AutoFit
    .Borders.Weight = 2
End With

[Bwambale]

Thanks Mick. I am not sure I explained just right what I am looking for. I have pasted your original code into my macro and my table now looks like:

Sheet 1 in example.

So now I want to look up column A as I did previously, but instead of taking the offset of 1 on "Sheet2" I want to take offset 6 say, and insert the list in a new column C. As per below:

Sheet 2 in attached example

Does that make sense or should we start again?

Thanks in advance for all your help!

[MickG]

Try this :-
NB:- See code comments for "Lookup column" and "Results column"

Sub MG24Feb15
Dim Rng As Range, Dn As Range, n As Long, Dic As Object, c As Long
Dim col As Long, rCol As String
rCol = "C" 'Change "rCol" to the Results column
col =  6 'Change lookup "Col" to the required Offets Column Number (6="G")
With Sheets("Sheet2")
Set Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
End With
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For Each Dn In Rng
    If Not Dic.exists(Dn.Value) Then
        Dic.Add Dn.Value, Dn.Offset(, col).Value
    Else
        If Not InStr(Dic(Dn.Value), Dn.Offset(, col).Value) > 0 Then
            Dic(Dn.Value) = Dic(Dn.Value) & ";" & Dn.Offset(, col)
        End If
    End If
Next
With Sheets("Sheet1")
Set Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp))
End With
c = 1
With Sheets("Sheet3")
.Cells(1, 1) = "Reference": .Cells(1, rCol) = "Results"
For Each Dn In Rng
    If Dic.exists(Dn.Value) Then
        c = c + 1
        .Cells(c, 1) = Dn.Value: .Cells(c, rCol) = Dic(Dn.Value)
    End If
Next Dn
End With

End Sub

Regards Mick

[Bwambale]

Perfect!! Thank you Mick!

[MickG]

You're welcome