VBA to move multiple rows into one row (columns to rows)

[Barry NP]

Hi all,

I am looking for some help and advice on a task that has landed on my desk!!

I have a set of data in Excel with supplier dates for Multiple & Duplicate vehicle Item No's across columns and then down rows with the part numbers. E.g.:

A	B	C	D	E	F	G
1	Item No
2	CT1	01/04/18	01/04/18	15/05/18	30/05/18
3	CT1	01/06/18	01/06/18	01/06/18	01/06/18
4	CT2	01/05/18	01/05/18	01/05/18	01/05/18	01/05/18
5	CT2	01/06/18	01/06/18	01/06/18	01/07/18	01/07/18
6	CT3	01/04/18	01/04/18	01/04/18	01/04/18
7	CT3	01/05/18	01/06/18	01/06/18	01/07/18	01/07/18

<tbody>
</tbody>

What I am trying to do with vba code (unsucsesfully so far! after searching extensively) is to combine and merge each Item number into one row with all dates showing for the item number so that I would get the below:

A	B	C	D	E	F	G	H	I	J	K	L
1	Item No
2	CT1	01/04/18	01/04/18	15/05/18	30/05/18	01/06/18	01/06/18	01/06/18	01/06/18
3	CT2	01/05/18	01/05/18	01/05/18	01/05/18	01/05/18	01/06/18	01/06/18	01/06/18	01/07/18	01/07/18
4	CT3	01/04/18	01/04/18	01/04/18	01/04/18	01/05/18	01/06/18	01/06/18	01/07/18	01/07/18

<tbody>
</tbody>

I'm not sure if I am attempting the impossible, but any help and advice would be greatly appreciated! This is just a small sample of the data which currently extends to circa 4000 rows and 60 columns.

Many thanks in advance!!

Barry.

 

[wideboydixon]

Are the item numbers already sorted in order? It's a much easier solution in this case. If not, it's still doable but needs a little more code.

WBD

 

[Barry NP]

Hi WBD.

Yes, the Item numbers are sorted in order in ascending order, if that helps!! Many thanks.

 

[wideboydixon]

I guessed as much so started writing the code anyway

Public Sub MultipleRowsToOneRow()

Dim lastRow As Long
Dim thisRow As Long
Dim lastCol As Long
Dim nextCol As Long

Application.ScreenUpdating = False
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
thisRow = 3
Do While thisRow <= lastRow
    If Cells(thisRow, "A").Value = Cells(thisRow - 1, "A").Value Then
        nextCol = Cells(thisRow - 1, Columns.Count).End(xlToLeft).Column + 1
        lastCol = Cells(thisRow, Columns.Count).End(xlToLeft).Column
        Range(Cells(thisRow, "B"), Cells(thisRow, lastCol)).Copy Destination:=Cells(thisRow - 1, nextCol)
        Cells(thisRow, "A").EntireRow.Delete
        lastRow = lastRow - 1
    Else
        thisRow = thisRow + 1
    End If
Loop
Application.ScreenUpdating = True

End Sub

WBD

 

[Barry NP]

Fab!! Many thanks WBD. Works like a charm. Just what I needed. Now I can continue!