Hello Fellow community members!
This is a query related to VBA code optimisation and I am a beginner so I do not have much experience in this area. I am currently working on an excel file for building a dashboard and it required cleaning the data in the spreadsheet. So I wrote a very simple VBA code that successfully works but it takes an unusual amount of time to execute (40-45 mins). I researched on the internet regarding this but couldnt find a solution. I would be very happy if someone could help me with optimising the VBA code that I have created (posted below) so that it takes hopefully a maximum of 5 or 10 mins to execute or even faster. The code is simple where it deletes the entire row if the given criteria is matched in the specified range in a column. Thank you in advance for your help and I will be very grateful as I am a student working on this project!
VBA Code:
Sub Dashboard()
Application.ScreenUpdating = False
Dim rng As Range, i As Integer
'Set range to evaluate
Set rng = Range("N8:N10000")
'Loop backwards through the rows in the range to evaluate
For i = rng.Rows.Count To 1 Step -1
'If cell i in the range contains "x", delete the entire row
If rng.Cells(i).Value = "John" Then rng.Cells(i).EntireRow.Delete
Next
'Delete name Tom
Set rng = Range("L8:L10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "TOM" Then rng.Cells(i).EntireRow.Delete
Next
'Delete Blanks
Set rng = Range("L8:L10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "" Then rng.Cells(i).EntireRow.Delete
Next
'Delete Blanks
Set rng = Range("O8:O10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "" Then rng.Cells(i).EntireRow.Delete
Next
'Delete Blanks
Set rng = Range("Q8:Q10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "" Then rng.Cells(i).EntireRow.Delete
Next
'Delete Blanks
Set rng = Range("R8:R10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "" Then rng.Cells(i).EntireRow.Delete
Next
'Delete Sara
Set rng = Range("R8:R10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "SARA" Then rng.Cells(i).EntireRow.Delete
Next
'Delete Ben
Set rng = Range("R8:R10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "BEN" Then rng.Cells(i).EntireRow.Delete
Next
'Delete Meredith
Set rng = Range("R8:R10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "MEREDITH" Then rng.Cells(i).EntireRow.Delete
Next
'Delete April
Set rng = Range("R8:R10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "APRIL" Then rng.Cells(i).EntireRow.Delete
Next
'Delete Jason
Set rng = Range("R8:R10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "JASON" Then rng.Cells(i).EntireRow.Delete
Next
'Delete Sana
Set rng = Range("R8:R10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "SANA" Then rng.Cells(i).EntireRow.Delete
Next
'Delete Blanks
Set rng = Range("AJ8:AJ10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "" Then rng.Cells(i).EntireRow.Delete
Next
'Delete June
Set rng = Range("AJ8:AJ10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "JUNE" Then rng.Cells(i).EntireRow.Delete
Next
'Delete October
Set rng = Range("AJ8:AJ10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "OCTOBER" Then rng.Cells(i).EntireRow.Delete
Next
'Delete January
Set rng = Range("AJ8:AJ10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "JANUARY" Then rng.Cells(i).EntireRow.Delete
Next
'Delete Blanks
Set rng = Range("AS8:AS10000")
For i = rng.Rows.Count To 1 Step -1
If rng.Cells(i).Value = "" Then rng.Cells(i).EntireRow.Delete
Next
Application.ScreenUpdating = True
End Sub
CodePudding user response：
Reduce it to one loop only
Option Explicit
Public Sub Dashboard()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Loop backwards through the rows in the range to evaluate
Dim i As Long
For i = 10000 To 8 Step -1
If Cells(i, "N").Value = "John" Or _
Cells(i, "L").Value = "TOM" Or _
Cells(i, "L").Value = vbNullString Or _
Cells(i, "O").Value = vbNullString Or _
Cells(i, "Q").Value = vbNullString Or _
Cells(i, "R").Value = vbNullString Or _
Cells(i, "R").Value = "SARA" Or _
Cells(i, "R").Value = "BEN" Or _
Cells(i, "R").Value = "MEREDITH" Or _
Cells(i, "R").Value = "APRIL" Or _
Cells(i, "R").Value = "JASON" Or _
Cells(i, "R").Value = "SANA" Or _
Cells(i, "AJ").Value = vbNullString Or _
Cells(i, "AJ").Value = "JUNE" Or _
Cells(i, "AJ").Value = "OCTOBER" Or _
Cells(i, "AJ").Value = "JANUARY" Or _
Cells(i, "AS").Value = vbNullString Then
Rows(i).EntireRow.Delete
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Or even faster: Collect all rows to delete in a variable and delete them all at once in the end:
Option Explicit
Public Sub Dashboard()
Dim RowsToDelete As Range
'Loop backwards through the rows in the range to evaluate
Dim i As Long
For i = 10000 To 8 Step -1
If Cells(i, "N").Value = "John" Or _
Cells(i, "L").Value = "TOM" Or _
Cells(i, "L").Value = vbNullString Or _
Cells(i, "O").Value = vbNullString Or _
Cells(i, "Q").Value = vbNullString Or _
Cells(i, "R").Value = vbNullString Or _
Cells(i, "R").Value = "SARA" Or _
Cells(i, "R").Value = "BEN" Or _
Cells(i, "R").Value = "MEREDITH" Or _
Cells(i, "R").Value = "APRIL" Or _
Cells(i, "R").Value = "JASON" Or _
Cells(i, "R").Value = "SANA" Or _
Cells(i, "AJ").Value = vbNullString Or _
Cells(i, "AJ").Value = "JUNE" Or _
Cells(i, "AJ").Value = "OCTOBER" Or _
Cells(i, "AJ").Value = "JANUARY" Or _
Cells(i, "AS").Value = vbNullString Then
' collect rows we want to delete in RowsToDelete
If RowsToDelete Is Nothing Then
Set RowsToDelete = Rows(i).EntireRow
Else
Set RowsToDelete = Union(RowsToDelete, Rows(i).EntireRow)
End If
End If
Next
'delete all at once in the end
If Not RowsToDelete Is Nothing Then
RowsToDelete.Delete
End If
End Sub
CodePudding user response：
Please, try the next code. It is compact, using a single iteration, an array to make the code faster and a Union range to keep cells of the rows to be deleted. These ones will be deleted at once, at the end of the code:
Sub Dashboard()
Dim sh As Worksheet, rng As Range, arr, rngDel As Range, rngAdd As Range, i As Long
Set sh = ActiveSheet
arr = sh.Range("L1:AS1000").value 'place the range in an array for faster iteration
For i = 8 To UBound(arr)
If arr(i, 3) = "John" Or arr(i, 1) = "TOM" Or arr(i, 1) = "" _
Or arr(i, 4) = "" Or arr(i, 6) = "" Or arr(i, 7) = "" _
Or arr(i, 7) = "BEN" Or arr(i, 7) = "SARA" Or arr(i, 7) = "MEREDITH" _
Or arr(i, 7) = "APRIL" Or arr(i, 7) = "JASON" Or arr(i, 7) = "SANA" _
Or arr(i, 25) = "" Or arr(i, 25) = "JUNE" Or arr(i, 25) = "OCTOBER" _
Or arr(i, 25) = "JANUARY" Or arr(i, 34) = "" Then
If rngDel Is Nothing Then
Set rngDel = sh.Range("A" & i)
Else
Set rngDel = Union(rngDel, sh.Range("A" & i))
End If
End If
Next i
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
End Sub
CodePudding user response：
A Bunch of ElseIf Statements
Sub FixDashboard()
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim lCell As Range
Set lCell = ws.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lCell Is Nothing Then Exit Sub
If lCell.Row < 8 Then Exit Sub
Dim drg As Range
Dim r As Long
Dim Dont As Boolean
For r = 8 To lCell.Row
If StrComp(CStr(ws.Cells(r, "N").Value), "John", vbTextCompare) = 0 Then
ElseIf StrComp(CStr(ws.Cells(r, "L").Value), "Tom", vbTextCompare) = 0 Then
ElseIf Len(CStr(ws.Cells(r, "L").Value)) = 0 Then
ElseIf Len(CStr(ws.Cells(r, "O").Value)) = 0 Then
ElseIf Len(CStr(ws.Cells(r, "Q").Value)) = 0 Then
ElseIf Len(CStr(ws.Cells(r, "R").Value)) = 0 Then
ElseIf StrComp(CStr(ws.Cells(r, "R").Value), "Sara", vbTextCompare) = 0 Then
ElseIf StrComp(CStr(ws.Cells(r, "R").Value), "Ben", vbTextCompare) = 0 Then
ElseIf StrComp(CStr(ws.Cells(r, "R").Value), "Meredith", vbTextCompare) = 0 Then
ElseIf StrComp(CStr(ws.Cells(r, "R").Value), "April", vbTextCompare) = 0 Then
ElseIf StrComp(CStr(ws.Cells(r, "R").Value), "Jason", vbTextCompare) = 0 Then
ElseIf StrComp(CStr(ws.Cells(r, "R").Value), "Sana", vbTextCompare) = 0 Then
ElseIf StrComp(CStr(ws.Cells(r, "R").Value), "Tom", vbTextCompare) = 0 Then
ElseIf Len(CStr(ws.Cells(r, "AJ").Value)) = 0 Then
ElseIf StrComp(CStr(ws.Cells(r, "AJ").Value), "June", vbTextCompare) = 0 Then
ElseIf StrComp(CStr(ws.Cells(r, "AJ").Value), "October", vbTextCompare) = 0 Then
ElseIf StrComp(CStr(ws.Cells(r, "AJ").Value), "January", vbTextCompare) = 0 Then
ElseIf Len(CStr(ws.Cells(r, "AS").Value)) = 0 Then
Else
Dont = True
End If
If Not Dont Then
If drg Is Nothing Then
Set drg = ws.Cells(r, "A")
Else
Set drg = Union(drg, ws.Cells(r, "A"))
End If
Else
Dont = False
End If
Next r
If drg Is Nothing Then Exit Sub
drg.EntireRow.Delete
End Sub
CodePudding user response：
If you may use a helper column, you may benefit from deleting all rows at once:
Sub Dashboard()
Application.ScreenUpdating = False
With Range("ZZ8:ZZ10000")
.Formula = "=IF(OR(L8=""TOM"",L8="""",O8="""",Q8="""",R8="""",R8=""SARA"",R8=""BEN"",R8=""MEREDITH"",R8=""APRIL"",R8=""JASON"",R8=""SANA"",AJ8=""""," & _
"AJ8=""JUNE"",AJ8=""OCTOBER"",AJ8=""JANUARY"",AS8=""""),""X"",1)"
.SpecialCells(xlCellTypeFormulas, 2).EntireRow.Delete
.ClearContents
End Sub
End With
Application.ScreenUpdating = True
End Sub
The code uses a helper column (in my code is ZZ but it can be anywhere) and types a formula of IG(OR...all your conditions). If any of those conditions is met, return "X" else return 1 (numeric value).
The formula will return a text or a numeric value depending on results. Then you may select all cells in that column that contains a formula returning a text (our X value) and delete all those rows at once.
Then the code clear the formula and leaves everything clean.
Advantages of this approach is that you don't loop at all and you delete all target rows at once. But disavantages is that if conditions changes frequently it can be annoying updating the code part.
Sources: