VBA Excel - identify duplicates and rearrange them

[norcorf]

Hi together, I am new here and that is my first question. I created the folowing macro and got stucked. So I need to indetify 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. Sublass column is simplified for a better overview. Duplicates values are grouped always together in sequential rows and are unique.
Here is initial data:


Complaint
Name
Subclass


624
XX
A


624
XX
B


624
XX
C


123
YY
A


123
YY
B


789
XY
A


256
ZZ
A


256
ZZ
B


256
ZZ
C



Here is how it should look like:



Complaint


Name
Subclass


624


XX
A


624

624
XX
B


624
624

XX
C


123


YY
A


123

123
YY
B


789


XY
A


256


ZZ
A


256

256
ZZ
B


256
256

ZZ
C



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.
Here is VBA I created:



Sub testworking()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Tabelle2")
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


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

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):



Complaint





Name
Subclass


624





XX
A


624




624
XX
B


624



624

XX
C


123





YY
A


123


123


YY
B


789





XY
A


256





ZZ
A


256

256



ZZ
B


256
256




ZZ
C



I appreciate any help :)

[Aussiebear]

Welcome to VBAX norcorf. Not sure what happened here but its highly unusual for a request to be made, then with no input from anyone else, for the thread to then be marked as Solved. So I have corrected your code layout and changed the Solved to Unsolved for you.

[p45cal]

Cross posted:
https://stackoverflow.com/questions/78678415/vba-excel-identify-duplicates-and-rearrange-them

[Aussiebear]

Perhaps norcorf will have the courage to apologise for failing to read the rules and for being discourteous to the members here for not indicating the cross post.... only time will tell.

[norcorf]

Yes, my bad. Since I got immediate response on stakeoverflow I wanted to freeze the thread until the solution works. I am going to add a cross posted link and a working code to my thread. Btw it took unusual a long time to complete a registration. That was actually a reason for cross posting.

[norcorf]

For some reason I can't edit my post. Therefore, here is the working code: https://stackoverflow.com/a/78678720/25767648

[Aussiebear]

The admin of this forum have set a predetermined time limit after which you cannot edit your posts. Here is the actual code


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