-1

I have a data set similar to the below:

Example data

I would like to convert the data to multiple columns where duplicate ID's (column 1) are removed and all other data is consolidated into single rows split across columns.

I have tried the following code from another thread:

Convert columns with multiple rows of data to rows with multiple columns in Excel.

However this results in column two data also being consolidated across columns where there are duplicates in rows.

For example, the above table would appear as

Current result

I need to amend the code so that it only removes duplicated data in column 1 and spreads the remaining data across columns.

I would like the data to end as follows:

Desired result

Below is the code i'm using:

Sub ConsolidateRows_SpreadAcross()

Dim lastRow As Long, i As Long, j As Long
Dim colMatch As Variant, colConcat As Variant

application.ScreenUpdating = False 'disable ScreenUpdating to avoid screen flashes

lastRow = range("A" & Rows.Count).End(xlUp).Row 'get last row

For i = lastRow To 2 Step -1

    If Cells(i, 2) = Cells(i - 1, 2) Then
        range(Cells(i, 3), Cells(i, Columns.Count).End(xlToLeft)).Copy Cells(i - 1, Columns.Count).End(xlToLeft).Offset(, 1)
        Rows(i).Delete
    Else
        If Cells(i, 1) = Cells(i - 1, 1) Then
            range(Cells(i, 2), Cells(i, Columns.Count).End(xlToLeft)).Copy _
                Cells(i - 1, Columns.Count).End(xlToLeft).Offset(, 1)
            Rows(i).Delete
        End If
    End If

Next

application.ScreenUpdating = True 'reenable ScreenUpdating

End Sub

Any assistance would be greatly appreciated.

Pᴇʜ
  • 56,719
  • 10
  • 49
  • 73
MaxT
  • 1

1 Answers1

0

With your data in its current pattern you do not need to check both column A and column B.

Sub ConsolidateRows_SpreadAcross()

    Dim i As Long, j As Long
    Dim colMatch As Variant, colConcat As Variant

    Application.ScreenUpdating = False 'disable ScreenUpdating to avoid screen flashes

    With Worksheets("sheet15")

        For i = .Cells(.Rows.Count, "A").End(xlUp).Row To 2 Step -1

            If .Cells(i, 1) = Cells(i - 1, 1) Then
                .Range(.Cells(i, 3), .Cells(i, .Columns.Count).End(xlToLeft)).Copy _
                  Destination:=.Cells(i - 1, .Columns.Count).End(xlToLeft).Offset(0, 1)
                .Rows(i).Delete
            End If

        Next i

        .Cells(1, "C").Resize(1, .Cells(1, 1).CurrentRegion.Columns.Count - 2) = "data"

    End With

    Application.ScreenUpdating = True 'reenable ScreenUpdating

End Sub