Merge Every 3 Rows into 1 row

sduttexcel

New Member
Joined
Mar 16, 2018
Messages
17
I have a data file of say 60,000 records and each record are up to column K. I need to combine every 3 rows as one row into a new worksheet.

Input rows will be: A2 to K2, A3 to K3 and A4 to K4

Output will be on a new worksheet will be from:
A2 to AG2

This formula will be for entire worksheet.

There for the quantity in the output file will be 20,000 records.
 

kweaver

Well-known Member
Joined
May 8, 2018
Messages
668
Here's one way that seems to work:

Code:
Sub Copy3Rows()
Dim LR As Long, i As Integer, j As Integer
LR = Cells(Rows.Count, "G").End(xlUp).Row
j = 2
For i = 2 To LR Step 3
Sheets("New").Range("A" & j, "K" & j).Value = Sheets("Original").Range("A" & i, "K" & i).Value
Sheets("New").Range("L" & j, "V" & j).Value = Sheets("Original").Range("A" & i + 1, "K" & i + 1).Value
Sheets("New").Range("W" & j, "AG" & j).Value = Sheets("Original").Range("A" & i + 2, "L" & i + 2).Value
j = j + 1
Next i
End Sub
 

sduttexcel

New Member
Joined
Mar 16, 2018
Messages
17
I got a Debug error

For i = 2 To LR Step 3

I just copied the code you have me. Don't know what I'm doing wrong.
 

kweaver

Well-known Member
Joined
May 8, 2018
Messages
668
Probably would get an error if the count from row 2 to N is not a multiple of 3.
I didn't include any error checking to confirm that.
 
Last edited:

sduttexcel

New Member
Joined
Mar 16, 2018
Messages
17
Not every time the data will be evenly divided by 3. What if I have 7,000 records. The last row will have 1 record only. Can I use Offset formula to do it?
 

kweaver

Well-known Member
Joined
May 8, 2018
Messages
668
How about this adjustment?

Code:
Sub Copy3Rows()
Dim LR As Long, i As Integer, j As Integer
LR = Sheets("Original").Cells(Rows.Count, "G").End(xlUp).Row
LR = LR + (1 + (LR - 2)) Mod 3
j = 2
For i = 2 To LR Step 3
Sheets("New").Range("A" & j, "K" & j).Value = Sheets("Original").Range("A" & i, "K" & i).Value
Sheets("New").Range("L" & j, "V" & j).Value = Sheets("Original").Range("A" & i + 1, "K" & i + 1).Value
Sheets("New").Range("W" & j, "AG" & j).Value = Sheets("Original").Range("A" & i + 2, "L" & i + 2).Value
j = j + 1
Next i
End Sub
 

kweaver

Well-known Member
Joined
May 8, 2018
Messages
668
I'm scratching my own head why I put "G" in this line. Change it to "A".

LR = Sheets("Original").Cells(Rows.Count, "A").End(xlUp).Row
 

jolivanes

Well-known Member
Joined
Sep 5, 2004
Messages
1,390
How long does this take?
Change Sheet references as required.
Code:
Sub Maybe()
Dim i As Long, j As Long
i = 2
    For j = 2 To WorksheetFunction.RoundUp(Cells(Rows.Count, 1).End(xlUp).Row / 3, 0)
        With Sheets("Sheet3")
            .Cells(j, 1).Resize(, 11).Value = Cells(i, 1).Resize(, 11).Value
            .Cells(j, 12).Resize(, 11).Value = Cells(i + 1, 1).Resize(, 11).Value
            .Cells(j, 23).Resize(, 11).Value = Cells(i + 2, 1).Resize(, 11).Value
        End With
        i = i + 3
    Next j
End Sub
 
Last edited:

kweaver

Well-known Member
Joined
May 8, 2018
Messages
668
I'll need more info as I've tried this with 6000+ rows and it works. What error did you get? How many rows are there?
 

Forum statistics

Threads
1,078,227
Messages
5,338,965
Members
399,272
Latest member
jakepenner

Some videos you may like

This Week's Hot Topics

Top