VBA Macro is excruciatingly slow - excel

Currently i have a perfectly functioning VBA Macro. Does everything it is required to. However, i do need some advice and help on speeding this macro up as it takes a LONG time to get things done. This macro takes aroung 5 minutes to sort through around 4k-5k populated rows, which then it hides some of the rows.
How this macro works is that it will sort through Column A, sorting through the names and comparing it to a list in Sheet1, where if the name matches the list in sheet1, it will proceed to hide the row.
Thanks in advance.
Sub FilterNameDuplicate()
Application.ScreenUpdating = False
Dim iListCount As Integer
Dim iCtr As Integer
Dim a As Long
Dim b As Long
Dim c As Long
Dim D As Long
a = Worksheets("Default").Cells(Rows.Count, "G").End(xlUp).Row
For c = 1 To a
b = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
For D = 1 To b
If StrComp(Worksheets("Sheet1").Cells(D, "A"), (Worksheets("Default").Cells(c, "G")), vbTextCompare) = 0 Then
Worksheets("Default").Rows(c).EntireRow.Hidden = True
End If
Next
Next
Application.ScreenUpdating = True
MsgBox "Done"
End Sub

All of your accesses to the worksheet really slows things down.
Much faster to use VBA arrays.
You can eliminate some of the looping by using the Range.Find method to determine if there are duplicates of the names on Default in Sheet1.
We collect the non-duplicated names (in a Collection) and then create an array to use as the argument for the Range.Filter method (which will effectively hide the entire row).
Accordingly:
Code edited to run faster using Match function
Option Explicit
Sub FilterNameDuplicate()
Dim ws1 As Worksheet, wsD As Worksheet
Dim v1 As Variant, vD As Variant, r1 As Range, rD As Range
Dim col As Collection
Dim R As Range, I As Long, arrNames() As String
With ThisWorkbook
Set ws1 = .Worksheets("Sheet1")
Set wsD = .Worksheets("Default")
End With
With ws1
Set r1 = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
v1 = r1
End With
With wsD
Set rD = Range(.Cells(1, 7), .Cells(.Rows.Count, 7).End(xlUp))
vD = rD
End With
'collect names on Default that are not on Sheet1
Set col = New Collection
With Application
For I = 2 To UBound(vD, 1)
If .WorksheetFunction.IsError(.Match(vD(I, 1), v1, 0)) Then col.Add vD(I, 1)
Next I
End With
'Filter to include those names
Application.ScreenUpdating = False
If wsD.FilterMode Then wsD.ShowAllData
ReDim arrNames(1 To col.Count)
For I = 1 To col.Count
arrNames(I) = col(I)
Next I
rD.AutoFilter field:=1, Criteria1:=arrNames, Operator:=xlFilterValues
End Sub

The main slow down is do to nested looping. Using a Collection or Dictionary for quicker lookups will speed up your code 100 times.
Sub FilterNameDuplicate()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Rem Unhide all the rows
Worksheets("Default").UsedRange.EntireRow.Hidden = False
Dim Keys As Collection
Set Keys = GKeys
Dim Key As String
Dim Target As Range
With Worksheets("Default")
Set Target = Intersect(.UsedRange, .Columns("G"))
End With
If Target Is Nothing Then
MsgBox "Invalid Range"
Exit Sub
End If
Dim Cell As Range
For Each Cell In Target
Key = UCase(Cell.Value)
On Error Resume Next
Key = Keys(Key)
Cell.EntireRow.Hidden = Err.Number <> 0
On Error GoTo 0
Next
Rem We no longer need to turn ScreenUpdating back on
Application.Calculation = xlCalculationAutomatic
MsgBox "Done"
End Sub
Function GKeys() As Collection
Set GKeys = New Collection
Dim Key As String
Dim Data As Variant
Data = Worksheets("Sheet1").Range("A1").CurrentRegion.Columns(1).Value
Dim r As Long
For r = 1 To UBound(Data)
Key = UCase(Data(r, 1))
On Error Resume Next
GKeys.Add Key:=Key, Item:=""
On Error GoTo 0
Next
End Function

Trying adding in this, it speeds up by turning off screen updating, events, animations etc, this should speed it up a bit!
At the start of your code add in this sub
Call TurnOffCode
At the end of your code add in this sub
Call TurnOnCode
This is what they should both look like
Sub TurnOffCode() 'Used to turn off settings to make workbook run faster
Application.Calculation = xlCalculationManual 'Set calculations to manual
Application.ScreenUpdating = False 'Turns off screen updating
Application.EnableEvents = False 'Turns off events
Application.EnableAnimations = False 'Turns off animations
Application.DisplayStatusBar = False 'Turns off display status bar
Application.PrintCommunication = False 'Turns off print communications
End Sub
Sub TurnOnCode() 'Used to turn settings back on to normal
Application.Calculation = xlCalculationAutomatic 'Set calculations to automatic
Application.ScreenUpdating = True 'Turns on screen updating
Application.EnableEvents = True 'Turns on events
Application.EnableAnimations = True 'Turns on animations
Application.DisplayStatusBar = True 'Turns on display status bar
Application.PrintCommunication = True 'Turns on print communications
End Sub

Related

Clean trim cells from column A and delete entire row with blank cell in column A

I am trying to trim clean column A then filter the blank cells in column A and delete the entire row based on blank cell present in column A.
Column A has a few blank cells. Those blank cells might have a space hence I first want to clean and trim column A and then filter on column A blank cell and delete the entire row.
Desired output:
Sub trimclean()
Dim lRow As Integer, i As Long
With Worksheets("Sandy")
lRow = .Range("A1").End(xlDown).Row
For i = 2 To lRow
.Cells(i, "A").Value = Trim(.Cells(i, "A").Value)
Next i
End With
End Sub
Sub DeleteBlanks()
Dim rDataToProcess As Range
Set rDataToProcess = ActiveWorkbook.Worksheets("Sandy").Range("A1").End(xlDown).Row.CurrentRegion
'Field in the below method refers to the column that is being filtered, so the second colum
rDataToProcess.AutoFilter field:=2, Criteria1:=""
rDataToProcess.Offset(1).Resize(rDataToProcess.Rows.Count).EntireRow.Delete
Sheet1.AutoFilterMode = False
End Sub
Problem in my code
For a start, it looks to be that your "Range" is actually a qualified table. If so, you can refer to the ListObjects in the worksheet and it makes it easier to modify the table.
It loops but at least you can see what it's doing. If you wanted it to delete all rows in a single call then that is possible but too many rows in the table and the deletion would need to be broken out and packetised.
Also, I'm not sure if you want to do it in two steps but I've provided for that here ...
2 Steps
Public Sub TrimCells()
Dim objTable As ListObject, lngRow As Long, lngColumnToTrim As Long
lngColumnToTrim = 1
Set objTable = GetTable
TogglePerformance False
With objTable.DataBodyRange
For lngRow = 1 To .Rows.Count
.Cells(lngRow, lngColumnToTrim) = Trim(.Cells(lngRow, lngColumnToTrim))
Next
End With
TogglePerformance True
End Sub
Public Sub DeleteBlankRows()
Dim objTable As ListObject, lngRow As Long, lngColumnToCheckForBlank As Long
lngColumnToCheckForBlank = 1
Set objTable = GetTable
TogglePerformance False
With objTable.DataBodyRange
For lngRow = .Rows.Count To 1 Step -1
If Len(.Cells(lngRow, lngColumnToCheckForBlank).Value) = 0 Then
.Rows(lngRow).Delete xlShiftUp
End If
Next
End With
TogglePerformance True
End Sub
Private Function GetTable() As ListObject
Set GetTable = ThisWorkbook.Worksheets("Sandy").ListObjects("MyTable")
End Function
Private Sub TogglePerformance(ByVal bOn As Boolean)
Application.ScreenUpdating = bOn
Application.EnableEvents = bOn
If bOn Then
Application.Calculation = xlCalculationAutomatic
Else
Application.Calculation = xlCalculationManual
End If
End Sub
... but if you're happy to do it one one step then that'd be easier I would've though.
1 Step
Public Sub DeleteBlankRows()
Dim objTable As ListObject, lngRow As Long, lngColumnToCheckForBlank As Long
lngColumnToCheckForBlank = 1
Set objTable = ThisWorkbook.Worksheets("Sandy").ListObjects("MyTable")
TogglePerformance False
With objTable.DataBodyRange
For lngRow = .Rows.Count To 1 Step -1
If Len(Trim(.Cells(lngRow, lngColumnToCheckForBlank).Value)) = 0 Then
.Rows(lngRow).Delete xlShiftUp
End If
Next
End With
TogglePerformance True
End Sub
Private Sub TogglePerformance(ByVal bOn As Boolean)
Application.ScreenUpdating = bOn
Application.EnableEvents = bOn
If bOn Then
Application.Calculation = xlCalculationAutomatic
Else
Application.Calculation = xlCalculationManual
End If
End Sub
... you just need to make sure you change your Table Name in the code or change it on the sheet itself.
I've also assumed that you want to check in the first column of the table. That made sense given you were checking column A on sheet.
Bottom line, your table could be anywhere and this would still work.

Delete row based on value in a column

I have the following code which works i.e. deletes a row in a worksheet when a specific column has a value of "PAID"
Sub RemoveRows()
Dim i As Long
Dim strtest As String
i = 1
Do While i <= ThisWorkbook.ActiveSheet.Range("AG1").CurrentRegion.Rows.Count
strtest = ThisWorkbook.ActiveSheet.Cells(i, 33).Text
If ThisWorkbook.ActiveSheet.Cells(i, 33).Text = "PAID" Then
ThisWorkbook.ActiveSheet.Cells(i, 33).EntireRow.Delete
Else
i = i + 1
End If
Loop
End Sub
However it is very slow on worksheet with 5000 rows.
Any ideas how to make it a lot faster?
There are several reasons which may affect code execution speed including approach / method of coding. See below revised code with comments.
Sub RemoveRowsV2()
Dim i As Long
Dim strtest As String
Dim rngDel As Range
i = 1
'\\ Control features which may affect code processing!
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Do While i <= ThisWorkbook.ActiveSheet.Range("AG1").CurrentRegion.Rows.Count
'\\ Build a union of all cells to be deleted
strtest = ThisWorkbook.ActiveSheet.Cells(i, 33).Value
If ThisWorkbook.ActiveSheet.Cells(i, 33).Value = "PAID" Then
If rngDel Is Nothing Then
Set rngDel = ThisWorkbook.ActiveSheet.Cells(i, 33)
Else
Set rngDel = Union(rngDel, ThisWorkbook.ActiveSheet.Cells(i, 33))
End If
Else
i = i + 1
End If
Loop
'\\ Delete them once
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
'\\ Reset features which may affect code processing!
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
Alternatively you can use macro recorder to get primary code based on AutoFilter as #BigBen has suggested!
A couple things you can try:
Add the statement 'Do Events' at a point within the looping. This "DoEvents is an Excel VBA command that temporarily pauses the execution of the macro to refresh the screen and execute any pending events in Excel." For example:
Do
' code execution...
DoEvents
Loop Until rowB = "" Or rowB11 = ""
Prior to looping you could add the statement "Application.ScreenUpdating = False". This turns off the refresh flickering you see of the worksheet during processing.
Application.ScreenUpdating = False

Using Dictionary method to match data from two worksheets 17,500 rows takes 15 mins

I am trying to find a way to speed up a way to refresh data. I import data to a worksheet called Dictionary. I then need to loop through rows 2 to 17,500 on Traffic Data worksheet. And based on a match in Column A . Add the data from the Dictionary file to the Traffic Data file. The code below works , but it is taking 15 mins to run on a high spec laptop. to loop through 17.500 rows of data in the Traffic Data worksheet. And 2492 rows in the Dictionary worksheet. There are fewer rows of data in the dictionary worksheet as there a duplicated values in the traffic file as rows are added each year. So there can be upto 8 rows of the same code in column A , each with a different year date. I cant work out why it is taking so long any help would be much appreciated
Sub CompareLists()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Dim RngList As New Scripting.Dictionary
Dim Rng As Range
Dim dict As Worksheet
Dim traffic As Worksheet
Set RngList = CreateObject("scripting.dictionary")
Set dict = Worksheets("Dictionary")
Set traffic = Worksheets("Traffic Data")
With RngList
.CompareMode = vbTextCompare
For Each Rng In dict.Range("A2", dict.Range("A" & Rows.Count).End(xlUp))
If Not .Exists(Rng.Value) Then .Add Rng.Value, Rng.row
Next Rng
For Each Rng In traffic.Range("A2", traffic.Range("A" & Rows.Count).End(xlUp))
If .Exists(Rng.Value) Then
Rng.Offset(, 1) = dict.Range("B" & RngList(Rng.Value)) 'Comp
Rng.Offset(, 124) = dict.Range("C" & RngList(Rng.Value)) 'Status
Rng.Offset(, 125) = dict.Range("E" & RngList(Rng.Value)) 'Trading Suspended
Rng.Offset(, 126) = dict.Range("F" & RngList(Rng.Value)) 'Trading End
Rng.Offset(, 136) = dict.Range("G" & RngList(Rng.Value)) 'area
Rng.Offset(, 128) = dict.Range("D" & RngList(Rng.Value)) 'zone
Else
Rng.Interior.ColorIndex = 3
End If
Next Rng
End With
Set RngList = Nothing
Application.ScreenUpdating = ScreenUpdateState
Application.DisplayStatusBar = statusBarState
Application.Calculation = calcState
Application.EnableEvents = eventsState
ActiveSheet.DisplayPageBreaks = displayPageBreaksState
End Sub
The .Value method that you call frequently is a bottleneck, also the formatting with .Interior.ColorIndex. Each cell access operation has overhead that makes it slow. It is a bit more complex, but extremely faster, to read a range of cells to a 2-dimension array and then reference it, so long that all you need are values and not e.g. formats. values can be pasted back in the same way in one shot if needed.
I don't have your dataset to check how to optimize, but using an array for the dict, and one for columns A:G of traffic.
To test out the performance difference, below are 2 subs that will create a new worksheet, and do 1 simple assignment to the cell value of a 40k cell range. The code using value takes ~10s on my machine, the one with array ~0.1s.
As for the .Interior.ColorIndex call, you may make it faster by filtering and the applying the style in one shot for visible cells but it's much more complicated and I do not have data how you could set up the filter, you should already see a great improvement in performance this way.
Sub testValue()
'setting up same conditions
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim r As Range
Dim cell As Variant
Dim t As Single
Dim ws As Worksheet
Set ws = Worksheets.Add
ws.Range("A1").Value = "start"
ws.Range("T2000").Value = "end" ' 40000 cells will be considered used
t = Timer
Set r = ws.UsedRange
' PART OF INTEREST START
For Each cell In r
cell.Value = "x"
Next cell
' PART OF INTEREST END
MsgBox (Timer - t)
ws.Activate
'reset setup
Application.ScreenUpdating = ScreenUpdateState
Application.DisplayStatusBar = statusBarState
Application.Calculation = calcState
Application.EnableEvents = eventsState
End Sub
Sub testArray()
'setting up same conditions
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim t As Single
Dim r As Range
Dim arr As Variant
Dim i As Long
Dim j As Long
Dim ws As Worksheet
Set ws = Worksheets.Add
ws.Range("A1").Value = "start"
ws.Range("T2000").Value = "end" ' 40000 cells will be considered used
t = Timer
Set r = ws.UsedRange
' PART OF INTEREST START
arr = r.Value
For i = LBound(arr, 1) To UBound(arr, 1)
For j = LBound(arr, 2) To UBound(arr, 2)
arr(i, j) = "x"
Next j
Next i
r.Value = arr
' PART OF INTEREST END
MsgBox (Timer - t)
ws.Activate
'reset setup
Application.ScreenUpdating = ScreenUpdateState
Application.DisplayStatusBar = statusBarState
Application.Calculation = calcState
Application.EnableEvents = eventsState
End Sub

How can I speed up this For Each loop in VBA?

I have an Worksheet_Change macro that hides/unhides rows depending on the choice a user makes in a cell with a data validation list.
The code takes a minute to run. It's looping over c.2000 rows. I'd like it to take closer to a few seconds so it becomes a useful user tool.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'Exit the routine early if there is an error
On Error GoTo EExit
'Manage Events
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
'Declare Variables
Dim rng_DropDown As Range
Dim rng_HideFormula As Range
Dim rng_Item As Range
'The reference the row hide macro will look for to know to hide the row
Const str_HideRef As String = "Hide"
'Define Variables
'The range that contains the week selector drop down
Set rng_DropDown = Range("rng_WeekSelector")
'The column that contains the formula which indicates if a row should
'be hidden c.2000 rows
Set rng_HideFormula = Range("rng_HideFormula")
'Working Code
'Exit sub early if the Month Selector was not changed
If Not Target.Address = rng_DropDown.Address Then GoTo EExit
'Otherwise unprotect the worksheet
wks_DailyPlanning.Unprotect (str_Password)
'For each cell in the hide formula column
For Each rng_Item In rng_HideFormula
With rng_Item
'If the cell says "hide"
If .Value2 = str_HideRef Then
'Hide the row
.EntireRow.Hidden = True
Else
'Otherwise show the row
.EntireRow.Hidden = False
End If
End With
'Cycle through each cell
Next rng_Item
EExit:
'Reprotect the sheet if the sheet is unprotected
If wks_DailyPlanning.ProtectContents = False Then wks_DailyPlanning.Protect (str_Password)
'Clear Events
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
I have looked at some links provided by other users on this website and I think the trouble lies in the fact I'm having to iterate through each row individually.
Is it possible to create something like an array of .visible settings I can apply to the entire range at once?
I'd suggest copying your data range to a memory-based array and checking that, then using that data to adjust the visibility of each row. It minimizes the number of interactions you have with the worksheet Range object, which takes up lots of time and is a big performance hit for large ranges.
Sub HideHiddenRows()
Dim dataRange As Range
Dim data As Variant
Set dataRange = Sheet1.Range("A13:A2019")
data = dataRange.Value
Dim rowOffset As Long
rowOffset = IIf(LBound(data, 1) = 0, 1, 0)
ApplicationPerformance Flag:=False
Dim i As Long
For i = LBound(data, 1) To UBound(data, 1)
If data(i, 1) = "Hide" Then
dataRange.Rows(i + rowOffset).EntireRow.Hidden = True
Else
dataRange.Rows(i + rowOffset).EntireRow.Hidden = False
End If
Next i
ApplicationPerformance Flag:=True
End Sub
Public Sub ApplicationPerformance(ByVal Flag As Boolean)
Application.ScreenUpdating = Flag
Application.DisplayAlerts = Flag
Application.EnableEvents = Flag
End Sub
Another possibility:
Dim mergedRng As Range
'.......
rng_HideFormula.EntireRow.Hidden = False
For Each rng_Item In rng_HideFormula
If rng_Item.Value2 = str_HideRef Then
If Not mergedRng Is Nothing Then
Set mergedRng = Application.Union(mergedRng, rng_Item)
Else
Set mergedRng = rng_Item
End If
End If
Next rng_Item
If Not mergedRng Is Nothing Then mergedRng.EntireRow.Hidden = True
Set mergedRng = Nothing
'........
to increase perfomance you can populate dictionary with range addresses, and hide or unhide at once, instead of hide/unhide each particular row (but this is just in theory, you should test it by yourself), just an example:
Sub HideHiddenRows()
Dim cl As Range, x As Long
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
x = Cells(Rows.Count, "A").End(xlUp).Row
For Each cl In Range("A1", Cells(x, "A"))
If cl.Value = 0 Then dic.Add cl.Address(0, 0), Nothing
Next cl
Range(Join(dic.keys, ",")).EntireRow.Hidden = False
End Sub
demo:

Speed up VBA code on extracting relevant rows to new worksheet

I need to copy relevant rows to a new Excel worksheet. The code will loop through each row in the original worksheet and select rows based on relevant countries and products specified in the array into the second worksheet.
Private Sub CommandButton1_Click()
a = Worksheets("worksheet1").Cells(Rows.Count, 2).End(xlUp).Row
Dim countryArray(1 To 17) As Variant
Dim productArray(1 To 17) As Variant
' countryArray(1)= "Australia" and so on...
' productArray(1)= "Product A" and so on...
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 3 To a
For Each j In countryArray
For Each k In productArray
Sheets("worksheet1").Rows(i).Copy Destination:=Sheets("worksheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
Next
Next
Next
Application.CutCopyMode = False
Application.ScreenUpdating = False
End Sub
Each time I ran the code, the spreadsheet stopped responding in a matter of minutes. Would appreciate if someone could help me on this, thanks in advance!
Here are some pointers:
Remember to declare all your variables and use Option Explicit at the top of your code
Use With statements to ensure working with right sheet and not implicit activesheet or you may end up with wrong end row count
Only i contributes to the loop so you are making unnecessary loop work
Gather qualifying ranges with Union and copy in one go
Remember to switch back on screen-updating
Code:
Option Explicit
Private Sub CommandButton1_Click()
Dim unionRng As Range, a As Long, i As Long
With Worksheets("worksheet1")
a = .Cells(.Rows.Count, 2).End(xlUp).Row
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For i = 3 To a
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, .Cells(i, 1))
Else
Set unionRng = .Cells(i, 1)
End If
Next
With Worksheets("worksheet2")
unionRng.EntireRow.Copy .Cells(.Rows.Count, "A").End(xlUp).Row +1
End With
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Resources