Excel VBA: How to find duplicates and transpose? - excel

Question

I would like to ask your help for this task.
The excel sheet contains duplicated items in ColumnA. I want to combine these duplicates into one row. Please see the picture.
As the actual picture shows, there are three As in ColumnA. For every A there are some cells from ColumnB. Lets say those are the values to A. The values from every rows are marked with different colors seperately.
I want to combine A's values into one row, as the target picture shows.
The excel sheet was pre-sorted, so that all duplicates from ColumnA always appear together.
Please be noticed there are also items without duplicates: There is only one E in ColumnA. No transpose is required for this row.
Please also be noticed that there could be more duplicted items in ColumnA. E.g. 10x Ts, or 30x Ks.
To make the task easier, it is no need to delete the blank rows after the transformation.
The colors are used only to show the problem, there is no color in the excel sheet.
So far for this task.
Actually I asked a similar question before: Excel VBA: How to transform this kind of cells?
In the link there are some very good codes, but sadly I am not capable to rewrite the code for this task.
So please help me~
But please dont forget to have a happy weekend~
Thanks!

Answer 1

Try the code below ("bonus" feature, also removes the empty rows).
As you wrote in your post, the data is sorted according to Column A, and there are no empty rows in your data.
Sub TransposeDup()
Dim LastCol, LastColCpy As Long
Dim lrow As Long
lrow = 1
While Cells(lrow, 1) <> ""
If Cells(lrow, 1) = Cells(lrow + 1, 1) Then
LastCol = Cells(lrow, Columns.Count).End(xlToLeft).Column
LastColCpy = Cells(lrow + 1, Columns.Count).End(xlToLeft).Column
Range(Cells(lrow + 1, 2), Cells(lrow + 1, LastColCpy)).Copy Destination:=Cells(lrow, LastCol + 1)
Rows(lrow + 1).EntireRow.Delete
Else
lrow = lrow + 1
End If
Wend
End Sub

Answer 2

Something like the following should get you in the right direction. This doesn't copy formats, but it gets the values. You could tweak it to get where you need to go though:
Sub dedup_and_concat()
Dim intWriteCol As Integer
Dim intReadCol As Integer
Dim intWriteRow As Integer
Dim intReadRow As Integer
Dim intStartRow As Integer
Dim intEndRow As Integer
Dim strPrevRowValue As String
'Start and end rows:
intStartRow = 1
intEndRow = 8
'initial values:
intWriteRow = 1
'Loop from your start row to your end row
For intReadRow = intStartRow To intEndRow 'beginning and ending rows
intReadCol = 2
'If we are at the first row, then just capture values
'Also if this is a new value, then reset all of the write variables
If intReadRow = intStartRow Or Sheet1.Cells(intReadRow, 1).Value <> Sheet1.Cells(intWriteRow, 1).Value Then
'set the row and initial column we are writing to
intWriteRow = intReadRow
intWriteCol = Sheet1.Cells(intReadRow, 1).End(xlToRight).Column() + 1
Else
'We are on a row that needs to be concatenated and deleted
'So loop through all of the columns to get their values
'And write their values to the read row and read col
Do Until Sheet1.Cells(intReadRow, intReadCol).Value = ""
Sheet1.Cells(intWriteRow, intWriteCol).Value = Sheet1.Cells(intReadRow, intReadCol).Value
'increment read and write columns
intWriteCol = intWriteCol + 1
intReadCol = intReadCol + 1
Loop
'remove this rows values
Sheet1.Rows(intReadRow).ClearContents
End If
Next intReadRow
End Sub