Previous Topic Next Topic

Multiple Rows to one Row

Solved/Closed
ad1959 Posts 10 Registration date Thursday March 6, 2014 Status Member Last seen August 18, 2020 - Aug 11, 2020 at 01:14 AM
TrowaD Posts 2900 Registration date Sunday September 12, 2010 Status Moderator Last seen September 12, 2022 - Aug 27, 2020 at 11:45 AM
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

Answer 1 / 2
TrowaD Posts 2900 Registration date Sunday September 12, 2010 Status Moderator Last seen September 12, 2022 523
Updated on Aug 24, 2020 at 12:16 PM
Hi Ad,

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

Best regards,
Trowa

0
Answer 2 / 2
TrowaD Posts 2900 Registration date Sunday September 12, 2010 Status Moderator Last seen September 12, 2022 523
Aug 27, 2020 at 11:45 AM
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
0