How to look for duplicates in first column, then copy / paste contents of second column?

Hi,

Very new VBA user here, but ran across an Excel problem that is seemingly unsolvable without VBA.

I have item #'s in column "A," (let's say, item 10, 11, 12, 13, 14...) and product #'s in column "B" (let's say product #'s AA, AB, AC, AD). Some items have more than one product associated.

How can I put all the product #'s for each item onto one row? See attachment for a small sample of the data.

Thanks for any help!!

Here is how I tried to write the code:

Sub FindDuplicates()
Dim RC As Integer
Dim i As Integer, j As Integer

'count the rows in the list
RC = Range("A1").CurrentRegion.Rows.Count

'loop through all the tags to find duplicates
For i = 2 To RC
    For j = 2 To RC
        
        If Cells(i, 1) = Cells(j, 2) Then Cells(j, 4).Select
        Selection.Cut
        Cells(i, 5).PasteSpecial Paste:=x1PasteValues
        End If
    Next i
        Next j

please attache any workbook with dummy data and show us how output should looks like

Hello speedyhub,

Finally I've created code for You - follow below points
1. sort your source array regarding ID
2. use provided procedure (copy it into module or to source code of your sheet)
3. use autofilter for get expected result

Sub GiveMeTransposeResult()
'Author: MaczaQ
Dim sAddr As String, source, tmp, cl As Range, colOffset as Integer
 
Set source = Range("A3:B20")  '<<<<------------------------------SOURCE-------------------------------------
'other way to set up source range if you want to select your source data just unhash below code
'Set source = Selection
colOffset = source.Columns.Count
 
  With source.Columns(1)
    Set tmp = .Cells(1, 1)
     For Each cl In .Cells
        'all groups excluding last group
        If cl.Value <> tmp.Value And cl.Address <> .Cells(.Cells.Count, 1).Address Then
          sAddr = tmp.Address & ":" & cl.Offset(-1).Address
           arr = Application.Transpose(Range(sAddr).Offset(, 1))
             If tmp.Address <> cl.Offset(-1).Address Then
               Range(tmp.Address).Offset(, colOffset).Resize(, UBound(arr)).Value = arr
             Else
               Range(tmp.Address).Offset(, colOffset).Value = arr
             End If
           Set tmp = cl
        End If
       
        'last group
        If cl.Address = .Cells(.Cells.Count, 1).Address Then
         sAddr = tmp.Address & ":" & cl.Address
           arr = Application.Transpose(Range(sAddr).Offset(, 1))
             If tmp.Address <> cl.Offset(-1).Address Then
                Range(tmp.Address).Offset(, colOffset).Resize(, UBound(arr)).Value = arr
             Else
                Range(tmp.Address).Offset(, colOffset).Value = arr
             End If
        End If
     Next cl
  End With
End Sub

If you will need any more help do not hasitate to post it.