Macro To Find Duplicates And Put In Another Column

[Dazzawm]

I need a code please to find duplicates in column A and find the numbers in column B and copy to column C separated by a /

As you can see there are 2 values in orange and 2 different numbers in B, the same with the values in yellow so I need the results like the second example below.

Book1
	A	B
1	Unique Identifier	Menu Code
2	M15705430000105	3
3	M15705430000134	3
4	M10700600069014	13
5	M10700600071022	17
6	M10700600073006	19
7	M10700600069015	20
8	M10700600070021	23
9	M10700600070022	24
10	M15705430000122	25
11	M10700600069015	26
12	M10700600070023	28
13	M10700600071017	29
14	M10700600071016	30
15	M10700600258009	32
16	M10700600073007	33
17	M10700600073008	34
18	M10700600073007	36
19	M10700600073007	37
20	M10700600073007	39
21	M10700600071009	45
22	M10700600074007	46
23	M10700600069011	50
24	M10700600070024	51
25	M10700600070009	53
26	M10700600071018	54
27	M10700600071006	55
28	M16808230000017	56
Sheet1

After code.

Book1
	A	B	C
1	Unique Identifier	Menu Code	After Code
2	M15705430000105	3	3
3	M15705430000134	3	3
4	M10700600069014	13	13
5	M10700600071022	17	17
6	M10700600073006	19	19
7	M10700600069015	20	20 / 26
8	M10700600070021	23	23
9	M10700600070022	24	24
10	M15705430000122	25	25
11	M10700600069015	26	20 / 26
12	M10700600070023	28	28
13	M10700600071017	29	29
14	M10700600071016	30	30
15	M10700600258009	32	32
16	M10700600073007	33	33 / 36 / 37 / 39
17	M10700600073008	34	34
18	M10700600073007	36	33 / 36 / 37 / 39
19	M10700600073007	37	33 / 36 / 37 / 39
20	M10700600073007	39	33 / 36 / 37 / 39
21	M10700600071009	45	45
22	M10700600074007	46	46
23	M10700600069011	50	50
24	M10700600070024	51	51
25	M10700600070009	53	53
26	M10700600071018	54	54
27	M10700600071006	55	55
28	M16808230000017	56	56
Sheet1

Thanks so much.

 

[Peter_SSs]

Give this a try with a copy of your worksheet.

Sub Combine_Dupes()
  Dim d As Object
  Dim a As Variant
  Dim i As Long
 
  Set d = CreateObject("Scripting.Dictionary")
  With Range("A2:C" & Range("A" & Rows.Count).End(xlUp).Row)
    a = .Value
    For i = 1 To UBound(a)
      If d.exists(a(i, 1)) Then
        d(a(i, 1)) = d(a(i, 1)) & " / " & a(i, 2)
      Else
        d(a(i, 1)) = a(i, 2)
      End If
    Next i
    For i = 1 To UBound(a)
      a(i, 3) = d(a(i, 1))
    Next i
    .Value = a
  End With
End Sub

Edit: Or you could try this marginally shorter one.

Sub Combine_Dupes_v2()
  Dim d As Object
  Dim a As Variant
  Dim i As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  With Range("A2:C" & Range("A" & Rows.Count).End(xlUp).Row)
    a = .Value
    For i = 1 To UBound(a)
        d(a(i, 1)) = d(a(i, 1)) & " / " & a(i, 2)
    Next i
    For i = 1 To UBound(a)
      a(i, 3) = d(a(i, 1))
    Next i
    .Value = a
    .Columns(3).TextToColumns DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 9), Array(3, 1))
  End With
End Sub

 

[Dazzawm]

Give this a try with a copy of your worksheet.

Sub Combine_Dupes()
  Dim d As Object
  Dim a As Variant
  Dim i As Long
 
  Set d = CreateObject("Scripting.Dictionary")
  With Range("A2:C" & Range("A" & Rows.Count).End(xlUp).Row)
    a = .Value
    For i = 1 To UBound(a)
      If d.exists(a(i, 1)) Then
        d(a(i, 1)) = d(a(i, 1)) & " / " & a(i, 2)
      Else
        d(a(i, 1)) = a(i, 2)
      End If
    Next i
    For i = 1 To UBound(a)
      a(i, 3) = d(a(i, 1))
    Next i
    .Value = a
  End With
End Sub

Edit: Or you could try this marginally shorter one.

Sub Combine_Dupes_v2()
  Dim d As Object
  Dim a As Variant
  Dim i As Long
 
  Set d = CreateObject("Scripting.Dictionary")
  With Range("A2:C" & Range("A" & Rows.Count).End(xlUp).Row)
    a = .Value
    For i = 1 To UBound(a)
        d(a(i, 1)) = d(a(i, 1)) & " / " & a(i, 2)
    Next i
    For i = 1 To UBound(a)
      a(i, 3) = d(a(i, 1))
    Next i
    .Value = a
    .Columns(3).TextToColumns DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 9), Array(3, 1))
  End With
End Sub

Second code works great, much obliged squire.

 

[Peter_SSs]

Cheers. Thanks for the confirmation.