Clever Geek Handbook

Combine two strings into one based on ref matching very slowly

I have some code to combine two strings into one based on the corresponding link. It initially consists of 10 columns initially, which will be combined into 20 columns.

The code works, but is very slow. It's almost like it will loop through each row in the sheet, not just based on the "LastRow" variable. Is this a problem or is it something else? If I turn off updates it is still slow. If I leave them on the screen, it just blinks forever until it kills it in the 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
+3


source to share


2 answers


I think slow slowdown is multiple copy and paste where you can just do it in one go.
Also if you are only checking Column 4 then just loop over there.
One more important thing: you cannot delete a line after copying it.
The lines move around and you don't get the expected results.
Try to get these lines first and delete in one go after the iteration is complete.
Try something a little cleaner and more direct:

Edit1: After looking at the code, it appears that you are trying to combine duplicates on one line.



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 know if this is really what you are trying to achieve. I based it solely on the code you posted. It took less than a second on my machine. NTN.

+3


source


You should try the following:



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
0


source






More articles:


All Articles