VBA Excel - identify duplicates and rearrange them

Question

I created the following macro and got stucked. So, I need to identify duplicates in column A and rearrange them in separate columns starting from the column left to column B according to a defined layout. If I find a new unique duplicate, macro should go back to the first column left to the column B und this column should be used as an insertion point.

That means all duplicates of the same occurrences should be placed in one column (2nd together, 3rd together and so on). However, I get a new column every time it finds a duplicate (even if it has a new value) and this column shifts to the left.

I used loop because the dataset is not constant, and the number of duplicates may vary.

I appreciate any help :)

Here is my VBA I created.

Sub testworking()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Table2")
    
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.count, "A").End(xlUp).Row

    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    Dim i As Long
    Dim value As Variant
    Dim colIndex As Long

    Dim colDict As Object
    Set colDict = CreateObject("Scripting.Dictionary")

    For i = 1 To lastRow
        value = ws.Cells(i, 1).value
        If dict.Exists(value) Then
            colIndex = colDict(value) - 1 ' Adjust to insert left to B
            If colIndex < 2 Then ' Ensure we do not go beyond column A
                colIndex = 2
            End If
            ws.Columns(colIndex).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
            ws.Cells(i, colIndex).value = value
        Else
            dict.Add value, 1
            colDict.Add value, ws.Cells(i, 1).Column ' Store the initial column index
        End If
    Next i

End Sub

Here is a dataset I got after macro has been performed. It is shifting every time it has found a duplicate (even if it is a new unique value).

Answer 1

Try this out:

Sub testworking()
    
    Dim ws As Worksheet, lastRow As Long, r As Long, v
    Dim maxCols As Long, dict As Object, col As Range, insCols As Long
    Dim c As Range, n As Long
    
    Set ws = ThisWorkbook.Sheets("Table2")
    Set col = ws.Columns(2)
    Set dict = CreateObject("Scripting.Dictionary")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    'find the number of columns needed for insertion
    For Each c In ws.Range("A2:A" & lastRow).Cells
        v = c.value
        dict(v) = dict(v) + 1
        If insCols < dict(v) Then insCols = dict(v)
    Next c
    If insCols = 1 Then Exit Sub 'no duplicates
    
    ws.Columns(2).Resize(, insCols - 1).Insert 'insert extra columns
    
    'distribute replicates
    For Each c In ws.Range("A3:A" & lastRow).Cells
        v = c.value
        If v = c.Offset(-1).value Then
            n = n + 1 'increment count
            c.Offset(0, insCols - n) = v
        Else
            n = 0     'reset count
        End If
    Next c
End Sub