Multiple Rows to one Row

Question

Previous Topic Next Topic

Multiple Rows to one Row

[Solved]

Report

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: 2782
Registration date: Sunday September 12, 2010
Status: Moderator
Last seen: August 2, 2021

- 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

Multiple Rows to one Row
Repeat multiple rows in excel - How-To - Excel
Excel: Sample Macro to Insert Multiple Rows - How-To - Excel
Excel - One macro for multiple row tasks - How-To - Excel
Multiple rows in one cell excel - How-To - Excel
Macro to Deleting Multiple Rows ✓ - Forum - Excel

2 replies

Reply Ask a question

TrowaD · Answer 1 · 2020-08-24T12:15:42-0400

Answer 1 / 2

TrowaD

Posts: 2782
Registration date: Sunday September 12, 2010
Status: Moderator
Last seen: August 2, 2021

468
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

TrowaD · Answer 2 · 2020-08-27T11:45:43-0400

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

Multiple Rows to one Row

2 replies

Your reply

Subscribe To Our Newsletter!