Combine two rows into one based on matching ref very slow

Question

I have some code to combine two rows into one based on a matching reference. There are 10 columns initially, which will become 20 columns, once the rows are combined.

The code works but is very slow. It's almost like it is looping every row in the sheet rather than just based on the "LastRow" variable. Is that the issue or is it something else? If I turn off updates it is still slow. If I leave them on the screen just flashes forever until kill it in task manager.

Sub CombineRows()
    'define variables
    Dim RowNum As Long, LastRow As Long
    Application.ScreenUpdating = False
    'start below titles and make full selection of data
    RowNum = 2
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    Range("A2", Cells(LastRow, 10)).Select
    'For loop for all rows in selection with cells
    For Each Row In Selection
        With Cells
        'if order number matches
            If Cells(RowNum, 4) = Cells(RowNum + 1, 4) Then
                'move attribute 2 up next to attribute 1 and delete empty line
                Cells(RowNum + 1, 1).Copy Destination:=Cells(RowNum, 11)
                Cells(RowNum + 1, 2).Copy Destination:=Cells(RowNum, 12)
                Cells(RowNum + 1, 3).Copy Destination:=Cells(RowNum, 13)
                Cells(RowNum + 1, 4).Copy Destination:=Cells(RowNum, 14)
                Cells(RowNum + 1, 5).Copy Destination:=Cells(RowNum, 15)
                Cells(RowNum + 1, 6).Copy Destination:=Cells(RowNum, 16)
                Cells(RowNum + 1, 7).Copy Destination:=Cells(RowNum, 17)
                Cells(RowNum + 1, 8).Copy Destination:=Cells(RowNum, 18)
                Cells(RowNum + 1, 9).Copy Destination:=Cells(RowNum, 19)
                Cells(RowNum + 1, 10).Copy Destination:=Cells(RowNum, 20)
                Rows(RowNum + 1).EntireRow.Delete
            End If
        End With
        'increase rownum for next test
        RowNum = RowNum + 1
    Next Row
    'turn on screen updating
    Application.ScreenUpdating = True
End Sub

score 3 · Accepted Answer · edited May 23 '17 at 10:26

I think what's taking it slow is the multiple copy and paste wherein you can just do it in one go.
Also, If you are checking Column 4 only, then just loop there.
Another important thing is you cannot delete the row after you copy it.
The rows will move and then you will not get your expected results.
Try to get those rows first and delete in one go after you finished the iteration.
Try something a bit cleaner and direct:

Edit1: After reviewing your code, it seems you are trying to combine duplicates in the same row.

Sub CombineRows()
    Dim RowNum As Long, LastRow As Long
    Dim c As Range, rngtodelete As Range
    Application.ScreenUpdating = False
    With Sheets("Sheet1")
        RowNum = 2
        LastRow = .Range("A" & Rows.Count).End(xlUp).Row
        For Each c In .Range("D2:D" & LastRow) 'Loop in D column only
            If c.Value2 = c.Offset(1, 0).Value2 Then
                'Cut and paste in one go
                c.Offset(1, -3).Resize(, 10).Cut .Range("K" & RowNum)
                'Mark the rows to delete
                If rngtodelete Is Nothing Then
                    Set rngtodelete = c.Offset(1, 0).EntireRow
                Else
                    Set rngtodelete = Union(rngtodelete, c.Offset(1, 0).EntireRow)
                End If
            End If
            RowNum = RowNum + 1
        Next
        If Not rngtodelete Is Nothing Then rngtodelete.Delete xlUp 'Delete in one go
    End With
    Application.ScreenUpdating = True
End Sub

You can also learn a lot if you read this POST.
I don't really know if this is what you're trying to achieve.
I based it solely on the code you posted. This took less than a second in my machine. HTH.

score 0 · Answer 2 · answered Dec 22 '14 at 02:16

You should try this:

Sub CombineRows()
    'define variables
    Dim RowNum As Long, LastRow As Long
    Application.ScreenUpdating = False
    'start below titles and make full selection of data
    RowNum = 2
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    'Range("A2", Cells(LastRow, 10)).Select
    'For loop for all rows in selection with cells
    'For Each Row In Selection
    '    With Cells
        'if order number matches
    With Worksheets("ABC") ' Whatever is the Tab name
        For RowNum = 2 To LastRow
            If .Cells(RowNum, 4) = .Cells(RowNum + 1, 4) Then
                'move attribute 2 up next to attribute 1 and delete empty line
                .Range(.Cells(RowNum + 1, 1), .Cells(RowNum + 1, 10)).Copy _
                        Destination:=.Range(.Cells(RowNum, 11), .Cells(RowNum, 20))
                'Cells(RowNum + 1, 1).Copy Destination:=Cells(RowNum, 11)
                'Cells(RowNum + 1, 2).Copy destination:=Cells(RowNum, 12)
                'Cells(RowNum + 1, 3).Copy destination:=Cells(RowNum, 13)
                'Cells(RowNum + 1, 4).Copy destination:=Cells(RowNum, 14)
                'Cells(RowNum + 1, 5).Copy destination:=Cells(RowNum, 15)
                'Cells(RowNum + 1, 6).Copy destination:=Cells(RowNum, 16)
                'Cells(RowNum + 1, 7).Copy destination:=Cells(RowNum, 17)
                'Cells(RowNum + 1, 8).Copy destination:=Cells(RowNum, 18)
                'Cells(RowNum + 1, 9).Copy destination:=Cells(RowNum, 19)
                'Cells(RowNum + 1, 10).Copy destination:=Cells(RowNum, 20)
                Rows(RowNum + 1).EntireRow.Delete
            End If
        Next
        'End With
    End With
        'increase rownum for next test
        RowNum = RowNum + 1
    'Next Row
    'turn on screen updating
    Application.ScreenUpdating = True
End Sub

thanks guys - both worked flawlessly, and gave me a better understanding — user3432849, Dec 22 '14 at 02:45
if you delete a row, lastrow will be 1 smaller, so i would prefer a while loop and update the lastrow value when deleting a row. also you can add application.enableevents=false, and application.calculation=xlmanual to make the code a bit faster — Patrick Lepelletier, Dec 24 '14 at 15:29
Rows should always be deleted bottom up as per Patrick's comment. — brettdj, Jan 04 '15 at 02:51

Combine two rows into one based on matching ref very slow

2 Answers2