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
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
