Combine two rows into one based on matching ref very slow - vba

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

Answer 1

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.

Answer 2

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