Menu
  1. Accueil
  2. Tech Forum
  3. Office Software
  4. Excel

Multiple Rows to one Row [Solved]

Report
Posts
10
Registration date
Thursday March 6, 2014
Status
Member
Last seen
August 18, 2020
 -
Posts
2673
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
October 26, 2020
 -
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
See more

2 replies

Answer 1 / 2
Posts
2673
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
October 26, 2020
 446
Hi Ad,

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

Best regards,
Trowa

Answer 2 / 2
Posts
2673
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
October 26, 2020
 446
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
Reply Ask a question