VBA Code to process large amounts of data quickly

dj1ceberg

New Member
Joined
Oct 27, 2011
Messages
4
I have a large set of data, about 50,000 rows by 25 columns. I need to filter down the data into 10 groups based on different criteria. I have tried 2 methods, both are taking the better part of 2 hours to complete. I am hoping someone can think of a faster way to do this.

For the first report, the rows contain people and amounts. I need to show all of the people that have a sum over a certain amount (which is manually entered on another sheet).

The first method I had was to use the first blank column and run a IF/SUMIF formula that says "DELETE" if it is under the amount I am looking for and then copy that down . That ends up taking about 10 minutes to finish. The I filter and delete the columns and that's another 10 minutes.

The second way I tried was doing a loop and stamping the fields with a delete and then filtering and deleting. That took the same amount of time. I tried deleting the rows one by one, problem with that is my sumif changes as rows are deleted, plus it was also time consuming.

I can post the code since I know people like seeing code, but I really am looking for a better way to filter out what I need and post it to the 10 reports

Code:
Sub TotalOver()
'
' TotalOver Macro
'


'
Dim RowCount As Long
Dim RowCountNew As Long
Dim NewSheetName As String
Dim rowIndex As Long
Dim sourceWorksheet As Worksheet
Dim calcFormula As Variant


    
'    On Error GoTo ErrorHandler
    Application.ScreenUpdating = False
    
    NewSheetName = "Total_Over"
    Sheets(NewSheetName).Select
    Cells.Select
    Selection.Delete shift:=xlUp
    Range("A1").Select
    Sheets("Import").Select
    Cells.Select
    Selection.Copy
    Sheets(NewSheetName).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    RowCount = Application.WorksheetFunction.CountA(Range("A:A"))
    Range("W2").Select
    ActiveCell.FormulaR1C1 = "=SUMIF(C[-22],RC[-22],C[-13])"
'   New loop code inserted in place of formula to increase speed, but doesn't
'    For rowIndex = 1 To RowCount
'     calcFormula = ActiveSheet.Evaluate("=SUM(SUMIF(A1:A" & RowCount & ",A" & ActiveCell.Row & ",J1:J" & RowCount & "))")
'     Delete each row one by one - removed due to changing sumif value
'     If calcFormula < Worksheets("Variables").Range("B9") Then Rows(ActiveCell.Row).EntireRow.Delete shift:=xlUp
'     If calcFormula < Worksheets("Variables").Range("B9") Then ActiveCell.Value = "DELETE"
'     ActiveCell.Offset(1, 0).Select
'    Next rowIndex
'   End of loop code
    Selection.AutoFill Destination:=Range("W2:W" & RowCount)
    Range("X2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-1]<Variables!R9C2,""DELETE"","""")"
    Selection.AutoFill Destination:=Range("X2:X" & RowCount)
    Cells.Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$X$" & RowCount).AutoFilter Field:=24, Criteria1:="<>"
    Rows("2:" & ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row).Delete shift:=xlUp
    RowCountNew = Application.WorksheetFunction.CountA(Range("A:A"))
    Selection.AutoFilter
    Columns("A:A").Select
    Selection.Copy
    Columns("X:X").Select
    ActiveSheet.Paste
    Sheets("Variables").Select
    Range("B14").Select
    Selection.FormulaArray = _
        "=SUM(IF(FREQUENCY(" & NewSheetName & "!C[-1], " & NewSheetName & "!C[-1])>0,1))"
    Range("B18").Select
    Selection.FormulaArray = _
        "=MAX(SUMIF(" & NewSheetName & "!R[-16]C[-1]:R[" & RowCountNew - 18 & "]C[-1]," & NewSheetName & "!R[-16]C[-1]:R[" & RowCountNew - 18 & "]C[-1]," & NewSheetName & "!R[-16]C[8]:R[" & RowCountNew - 18 & "]C[8]))"
    Range("B17").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R[1]C," & NewSheetName & "!C[21]:C[22],2,FALSE)"
    Range("B17").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("B22").Select
    Selection.FormulaArray = _
        "=MIN(SUMIF(" & NewSheetName & "!R[-20]C[-1]:R[" & RowCountNew - 22 & "]C[-1]," & NewSheetName & "!R[-20]C[-1]:R[" & RowCountNew - 22 & "]C[-1]," & NewSheetName & "!R[-20]C[8]:R[" & RowCountNew - 22 & "]C[8]))"
    Range("B21").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R[1]C," & NewSheetName & "!C[21]:C[22],2,FALSE)"
    Range("B21").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Sheets(NewSheetName).Select
    Columns("W:X").Select
    Selection.Delete shift:=xlToLeft
    Range("A1").Select
    Sheets("Variables").Select
    Range("A1").Select
    Application.ScreenUpdating = True
    If ProcessAll = "" Then MsgBox NewSheetName & " Update Complete"
    Exit Sub
    
ErrorHandler:
    Application.ScreenUpdating = True
    Select Case Err
        Case 1004
            Sheets.Add After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Select
            Sheets(Sheets.Count).Name = NewSheetName
            Resume Next
        Case Else
    MsgBox "Error # " & Err & " : " & Error(Err)
'    MsgBox "Error is not fatal, script will continue"
'    Resume Next
    End Select
    
End Sub
 

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.
Don't have Excel right now but a couple of things to do with the existing code would be to go through and remove Select.Selection from the code....eg...
This
Code:
Cells.Select
Selection.Copy
could be
Code:
Cells.Copy
Even though I don't know why you would need to copy ALL cells in a sheet !
it could be
Code:
usedrange.Copy
instead !!
Also, add this to the start of your code
Code:
Application.screenupdating=False
and this to the end of the code
Code:
Application.screenupdating=True
It also appears you are deleting rows from the top down in the loop....the loop should always start at the bottom and work up when deleting rows
 
Upvote 0
Untested
Code:
Sub TotalOver()
Dim RowCount As Long, RowCountNew As Long, NewSheetName As String
Dim rowIndex As Long, sourceWorksheet As Worksheet, calcFormula As Variant

'    On Error GoTo ErrorHandler
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

NewSheetName = "Total_Over"
Sheets(NewSheetName).UsedRange.ClearContents
Sheets("Import").UsedRange.Copy Sheets(NewSheetName).Range("A1")
RowCount = Application.WorksheetFunction.CountA(Range("A:A"))
Range("W2:W" & RowCount).FormulaR1C1 = "=SUMIF(C[-22],RC[-22],C[-13])"
'   New loop code inserted in place of formula to increase speed, but doesn't
    For rowIndex = RowCount To 1 Step -1
        calcFormula = ActiveSheet.Evaluate("=SUM(SUMIF(A1:A" & RowCount & ",A" & ActiveCell.Row & ",J1:J" & RowCount & "))")
        If calcFormula < Worksheets("Variables").Range("B9") Then Rows(ActiveCell.Row).EntireRow.Delete shift:=xlUp
        If calcFormula < Worksheets("Variables").Range("B9") Then ActiveCell.Value = "DELETE"
        ActiveCell.Offset(1, 0).Select
    Next rowIndex
'   End of loop code
Range("X2").FormulaR1C1 = "=IF(RC[-1]0,1))"
Range("B18").FormulaArray = _
    "=MAX(SUMIF(" & NewSheetName & "!R[-16]C[-1]:R[" & RowCountNew - 18 & "]C[-1]," & NewSheetName & "!R[-16]C[-1]:R[" & RowCountNew - 18 & "]C[-1]," & NewSheetName & "!R[-16]C[8]:R[" & RowCountNew - 18 & "]C[8]))"
Range("B17").FormulaR1C1 = "=VLOOKUP(R[1]C," & NewSheetName & "!C[21]:C[22],2,FALSE)"
With Range("B17")
    .Value = .Value
End With
Range("B22").FormulaArray = _
    "=MIN(SUMIF(" & NewSheetName & "!R[-20]C[-1]:R[" & RowCountNew - 22 & "]C[-1]," & NewSheetName & "!R[-20]C[-1]:R[" & RowCountNew - 22 & "]C[-1]," & NewSheetName & "!R[-20]C[8]:R[" & RowCountNew - 22 & "]C[8]))"
Range("B21").FormulaR1C1 = "=VLOOKUP(R[1]C," & NewSheetName & "!C[21]:C[22],2,FALSE)"
With Range("B21")
    .Value = .Value
End With
Sheets(NewSheetName).Columns("W:X").Delete
Sheets("Variables").Range("A1").Select
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
If ProcessAll = "" Then MsgBox NewSheetName & " Update Complete"
Exit Sub

ErrorHandler:
    Select Case Err
        Case 1004
            Sheets.Add After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Select
            Sheets(Sheets.Count).Name = NewSheetName
            Resume Next
        Case Else
    MsgBox "Error # " & Err & " : " & Error(Err)
'    MsgBox "Error is not fatal, script will continue"
'    Resume Next
    End Select
    
End Sub
 
Upvote 0
I haven't looked at your code. But based on your description, why not simply filter the data and copy the filtered results:

- In Excel, Data/Filter to put the filter on.

- Click on the filter icon in the column you want to filter, and there is a Number Filters option that will let you specify number ranges.

- Copy/Paste the filtered results.

The macro recorder will help you with the syntax for automating in VBA.
 
Upvote 0

Forum statistics

Threads
1,223,234
Messages
6,170,891
Members
452,366
Latest member
TePunaBloke

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top