Multiple Rows to one Row [Solved]

Report
Posts
10
Registration date
Thursday March 6, 2014
Status
Member
Last seen
August 18, 2020
-
Posts
2717
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
April 1, 2021
-
Hi,
I have data supplied as -


And require it to be copied to this format-


How can i do this without multiple copy and pasting.

Thanks in advance
AD

2 replies

Posts
2717
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
April 1, 2021
458
Hi Ad,

Just letting you know that I'm looking into it Ad.

Best regards,
Trowa

Posts
2717
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
April 1, 2021
458
Hi Ad,

You can give the following code a try:
Sub RunMe()
Dim sSheet, dSheet As Worksheet
Dim x, y As Integer
'Source and Destination sheets. Adjust to match yours.
Set sSheet = Sheets("Sheet1")
Set dSheet = Sheets("Sheet2")
x = 5

sSheet.Range("A5:D" & sSheet.Range("A5").End(xlDown).Row).Copy dSheet.Range("A5")
dSheet.Range("A5:D" & dSheet.Range("A5").End(xlDown).Row).RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlNo

For Each cell In dSheet.Range("A5:A" & Range("A" & Rows.Count).End(xlUp).Row)
    Do
        If cell.Value = sSheet.Range("A" & x).Value Then
        y = 5
            Do
                If sSheet.Range("E" & x).Value = dSheet.Cells(2, y).Value Then Exit Do
                y = y + 6
            Loop Until dSheet.Cells(2, y).Value = vbNullString
            sSheet.Range(sSheet.Cells(x, "F"), sSheet.Cells(x, "K")).Copy dSheet.Cells(cell.Row, y)
        End If
        x = x + 1
    Loop Until cell.Value <> sSheet.Range("A" & x).Value
Next cell
End Sub


Best regards,
Trowa

Subscribe To Our Newsletter!

The Best of CCM in Your Inbox

Subscribe To Our Newsletter!