Combine matches

[liampog]

Hi

On Sheet1, I have the following columns of data

	A	B	C	D
1	DATE	NUMBER	NAME	TYPE(S)
2	01/01/2019	123	J Bloggs	A,B
3	01/01/2019	456	D Smith	A
4	01/01/2019	789	P Jones	B,C
5	02/01/2019	123	J Bloggs	B
6	02/01/2019	789	P Jones	D
7	03/01/2019	456	D Smith	A,B,C
8	03/01/2019	789	P Jones	C
9	03/01/2019	000	J Doe	A
10	03/01/2019	123	J Bloggs	A,C
11	04/01/2019	456	D Smith	A
12	05/01/2019	123	J Bloggs	A,B
13	05/01/2019	456	D Smith	B,D

<tbody>
</tbody>

On Sheet2, I have the desired output shown below.

I have already created VBA that copies the B column from Sheet1 to Sheet2 and then removes duplicates to create a unique list of numbers. I then have a VLOOKUP set up to capture the name associated with the number. My problem is Column C on Sheet2.

I want to combine all of the Types from each customer, removing any duplicate entries.

The desired output is below and you can cross-reference this to Sheet1

	A	B	C
1	NUMBER	NAME	TYPE(S)
2	123	J Bloggs	A,B,C
3	456	D Smith	A,B,C,D
4	789	P Jones	B,C,D
5	000	J Doe	A

<tbody>
</tbody>

Is there a formula that can achieve this? I'm sure there probably is but my knowledge of Excel formulas isn't amazing.

Thanks

 

[liampog]

How about the VBA code you provided prior? Editing it down so that it only focuses on extracting the Type data from Sheet1 that corresponds to the unique Number in Column A on Sheet2?

The VBA you provided works perfectly, but I don't need it to do anything about the Number and Name as this is all handled with VLOOKUPs.

I think I can create a Worksheet_Change event on Sheet1 that fires the code you gave whenever any Type data is changed.

I don't know anywhere near enough about VBA to be able to edit your VBA down to only do the above.

Thanks in advance
Liam

Sub liampog()   Dim Cl As Range
   Dim Dic As Object
   Dim Ky As Variant
   Dim i As Long
   
   Set Dic = CreateObject("scripting.dictionary")
   For Each Cl In Range("B2", Range("B" & Rows.Count).End(xlUp))
      If Not Dic.Exists(Cl.Value) Then
         Dic.Add Cl.Value, Array(Cl.Offset(, 1).Value, CreateObject("system.collections.arraylist"))
      End If
      Ky = Split(Cl.Offset(, 2).Value, ",")
      For i = 0 To UBound(Ky)
         With Dic(Cl.Value)(1)
            If Not .contains(CStr(Ky(i))) Then .Add CStr(Ky(i))
         End With
      Next i
   Next Cl
   i = 1
   For Each Ky In Dic.Keys
      i = i + 1
      Dic(Ky)(1).Sort
      Sheets("sheet2").Range("A" & i).Resize(, 3).Value = Array(Ky, Dic(Ky)(0), Join(Dic(Ky)(1).toarray, ","))
   Next Ky
End Sub

 

[Fluff]

Surely if somebody adds more data to sheet1 you will need to rerun your existing macro incase there is a new number in col B. In which case you can simply run my initial code which will do everything.

 

[liampog]

No it's not, but similar
Although I forgot a bit, use

Sub liampog()
   Dim Cl As Range
   Dim Dic As Object
   Dim Ky As Variant
   Dim i As Long
   
   Set Dic = CreateObject("scripting.dictionary")
   For Each Cl In Range("B2", Range("B" & Rows.Count).End(xlUp))
      If Not Dic.Exists(Cl.Value) Then
         Dic.Add Cl.Value, Array(Cl.Offset(, 1).Value, CreateObject("system.collections.arraylist"))
      End If
      Ky = Split(Cl.Offset(, 2).Value, ",")
      For i = 0 To UBound(Ky)
         With Dic(Cl.Value)(1)
            If Not .contains(CStr(Ky(i))) Then .Add CStr(Ky(i))
         End With
      Next i
   Next Cl
   i = 1
   For Each Ky In Dic.Keys
      i = i + 1
      Dic(Ky)(1).Sort
      Sheets("sheet2").Range("A" & i).Resize(, 3).Value = Array(Ky, Dic(Ky)(0), Join(Dic(Ky)(1).toarray, ","))
   Next Ky
End Sub

Fluff

I used this solution in the end, however, is there any way of it just pulling the unique number in Column B of Sheet 1 and combining the unique values in Column D of Sheet 1 into Column A of Sheet2 and Column E respectively?

Thanks in advance.
Liam

 

[Fluff]

How about

Sub liampog()
   Dim Cl As Range
   Dim Dic As Object
   Dim Ky As Variant
   Dim i As Long
   
   Set Dic = CreateObject("scripting.dictionary")
   For Each Cl In Range("B2", Range("B" & Rows.Count).End(xlUp))
      If Not Dic.Exists(Cl.Value) Then
         Dic.Add Cl.Value, CreateObject("system.collections.arraylist")
      End If
      Ky = Split(Cl.Offset(, 2).Value, ",")
      For i = 0 To UBound(Ky)
         With Dic(Cl.Value)
            If Not .contains(CStr(Ky(i))) Then .Add CStr(Ky(i))
         End With
      Next i
   Next Cl
   i = 1
   For Each Ky In Dic.keys
      i = i + 1
      Dic(Ky).Sort
      Sheets("sheet2").Range("A" & i).Value = Ky
      Sheets("sheet2").Range("E" & i).Value = Join(Dic(Ky).toarray, ",")
   Next Ky
End Sub

 

[liampog]

That's perfect, thank you.

Liam

 

[Fluff]

You're welcome & thanks for the feedback