Quicker function than delete entire row

[davidparkes]

Hi

I have some example data and macro attached that has about 20,000 rows in size the real data maybe upto 100,000 rows.

Is there a quicker way of combinig the data as per the macro using clear contents of the row and resort or some other logical test ?

The delete entire row takes 3mins to run for the 20,000 test rows.

Any help would be good

Thanks
David

[Chinchin]

Try this:

Sub quicker()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'your code

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

end sub

[davesexcel]

The fastest way to do a loop is not selecting cells, for example this code will copy and paste all the used cells into the other worksheet

Sub DoStuff()

    Dim Rws As Long, Col As Integer, r As Range, fRng As Range
    With Worksheets("DataIn")

        Set r = Range("A1")

        Rws = .Cells.Find(What:="*", After:=r, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

        Col = .Cells.Find(What:="*", After:=r, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

        Set fRng = .Range(.Cells(1, 1), .Cells(Rws, Col))    ' range A1 to last cell on sheet

        fRng.Copy Sheets("Combined").Range("A1")    'or whatever you want to do with the range
    End With

End Sub

I am not sure what you are doing with the other part of the code, so I am not going to get into it.
If you attach another sample workbook showing what the desired results are to be, that would be a great benefit, you only need to provide 50 to 100 rows as the code somebody will provide to you will probably be dynamic.

[davidparkes]

Hi

Basically if B1=B2 and C1=C2, then add the value of F2 to F1 and then delete row 2 and so on.

This take a long time due to the delete row function.

I was wondering if there was a better/quicker way of writing this, i.e.

if B1=B2 and C1=C2, then add F2 to F1 and then clear contents of row 2, then check if B1=B3 and C1=C3 if so add F3 to F1 and so on, but if B1<>B2 or C1<>C2 then move down one row or to the next occupied cell in column B.

Then I can resort which will remove the blank rows.

I hope this makes sense.

Thanks
David

[Chinchin]

Try this - I've found that unioning then removing all at once is faster than one by one:

Sub quicker()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim UnionRng As Range
Dim i As Integer

For i = Range("A60000").End(xlUp).Row To 2 Step -1
    If Range("A" & i).Value = Range("A" & i - 1).Value And _
      Range("B" & i).Value = Range("B" & i - 1).Value Then

        Range("F" & i - 1).Value = Range("F" & i - 1).Value + Range("F" & i).Value
    
        If UnionRng Is Nothing Then
            Set UnionRng = Range("A" & i)
        Else
            Set UnionRng = Union(UnionRng, Range("A" & i))
        End If
        
    End If
Next i

If Not UnionRng Is Nothing Then UnionRng.EntireRow.Delete


Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
end sub

[Whizbang]

Try this:

Sub CombineRecords()

Dim CalcSetting As String
Dim Cll As Range

    Application.ScreenUpdating = False
    CalcSetting = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Range("A:G").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom
    
    For Each Cll In Range("A2:A" & Range("A2").End(xlDown).Row)
        If Cll.Offset(0, 1) = Cll.Offset(-1, 1) And Cll.Offset(0, 2) = Cll.Offset(-1, 2) Then
            Cll.Offset(0, 5) = Cll.Offset(0, 5) + Cll.Offset(-1, 5)
            Cll.Offset(-1, 0).EntireRow.ClearContents
        End If
    Next Cll
    
    Range("A:G").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:= _
        False, Orientation:=xlTopToBottom
    
    Application.ScreenUpdating = True
    Application.Calculation = CalcSetting

End Sub

[Krishnakumar]

Hi,

Try

Sub kTest()

    Dim ka, i As Long, k(), n As Long, strConcat As String
    Dim c As Long, t()
    
    ka = Sheets("DataIn").[a1].CurrentRegion.Resize(, 7)
    
    ReDim k(1 To UBound(ka, 1), 1 To UBound(ka, 2))
    
    With CreateObject("scripting.dictionary")
        .comparemode = 1
        For i = 1 To UBound(ka, 1)
            strConcat = ka(i, 2) & "|" & ka(i, 3)
            If Not .exists(strConcat) Then
                n = n + 1
                For c = 1 To UBound(ka, 2): k(n, c) = ka(i, c): Next
                .Add strConcat, Array(n, UBound(ka, 2))
            Else
                t = .Item(strConcat)
                k(t(0), 6) = k(t(0), 6) + ka(i, 6)
            End If
        Next
    End With
    If n Then
        Sheets("Combined").[a1].Resize(n, UBound(k, 2)).Value = k
    End If

End Sub

HTH

[Marcol]

Here is another attempt, it doesn't involve looping, it might be quicker this way.

Option Explicit

Sub testclear()
    Dim wsIn As Worksheet, wsOut As Worksheet
    Dim LastRow As Long, RowNo As Long
    Dim LastCol As Long, ColNo As Long
    Dim strFmla1 As String, strFmla2 As String, strFmla3 As String, strFmla4 As String

    Set wsIn = Sheets("DataIn")
    Set wsOut = Sheets("Combined")

    With wsIn
        LastRow = .Range("A" & Rows.Count).End(xlUp).Row
        LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
        .Range(.Cells(2, 1), .Cells(LastRow, LastCol)).Sort Key1:=Range("B1"), Order1:=xlAscending, _
                                                            Key2:=Range("C1"), Order2:=xlAscending
    End With

    strFmla1 = "=IF(B2&C2=B3&C3," & Chr(34) & "Delete" & Chr(34) & ","""")"
    strFmla2 = "=IF(B2&C2=B1&C1,0,IF(B2&C2=B3&C3," & Chr(34) & "Delete" & Chr(34) & ",""""))"
    strFmla3 = "=IF(I2="""","""",IF(I2=" & Chr(34) & "Delete" & Chr(34) & ",I2,IF(ISNUMBER(J1),J1+F2,F1+F2)))"
    strFmla4 = "=IF(H2=" & Chr(34) & "Delete" & Chr(34) & ",H2,IF(J2="""",F2,J2))"

    With wsIn
        .Range(.Cells(2, LastCol + 1).Address).Resize(LastRow - 1, 1).Formula = strFmla1
        .Range(.Cells(2, LastCol + 2).Address).Resize(LastRow - 1, 1).Formula = strFmla2
        .Range(.Cells(2, LastCol + 3).Address).Resize(LastRow - 1, 1).Formula = strFmla3
        .Range(.Cells(2, LastCol + 4).Address).Resize(LastRow - 1, 1).Formula = strFmla4
        .Range(.Cells(2, LastCol + 4).Address).EntireColumn.Copy
        .Range(.Cells(1, LastCol + 4).Address).PasteSpecial xlValues
        .Range(.Cells(2, LastCol + 1), .Cells(2, LastCol + 3)).EntireColumn.Delete
        .Range(.Cells(1, 1), .Cells(1, LastCol + 1)).EntireColumn.Copy wsOut.Range("A1")
        .Range(.Cells(2, LastCol + 1).Address).EntireColumn.Clear
    End With

    With wsOut
        .Range(.Cells(2, LastCol + 1), .Cells(LastRow, LastCol + 1)).Copy
        .Range("F2").PasteSpecial xlValues
        .Range(.Cells(2, LastCol + 1), .Cells(LastRow, LastCol + 1)).Clear
        .Range(.Cells(1, 1), .Cells(LastRow, LastCol)).AutoFilter Field:=6, Criteria1:="Delete"
        .Rows("2:" & LastRow).Delete Shift:=xlUp
        .Range(.Cells(1, 1), .Cells(LastRow, LastCol)).AutoFilter
    End With

End Sub

The code could possibly be tidied a bit.

Hope this helps

[davidparkes]

Hi Guys

Thankyou to you all for your help, and solutions.

It's amazing you can have so many different ways to do the same task...

I shall mark this as solved and add to your rep's

Cheers
David