# 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 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 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.

## 2 responses

TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 552
Updated on Aug 24, 2020 at 12:16 PM

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

Best regards,
Trowa

TrowaD Posts 2921 Registration date Sunday September 12, 2010 Status Moderator Last seen December 27, 2022 552
Aug 27, 2020 at 11:45 AM

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