I have a spreadsheet which hides all rows except those designated by a date and a named region like so:
'Get week no value...
wk = Range("$B$2").Value
'If value changes...
If Target.Address = "$B$2" Then
'Hide all rows/weeks...
Range("allWeeks").Select
Application.Selection.EntireRow.Hidden = True
'...but show week selected by 'wk'
Range(wk).Select
Application.Selection.EntireRow.Hidden = False
All works great. However. Within each named week I have hidden calculation rows defined by "HC" in column A of the row to be hidden. The display of Range(wk) unhides those hidden rows so I introduce a loop to close all the "HC" hidden columns
Dim x As Integer
For x = 1 To 1500
If Sheet1.Cells(x, 1).Value = "HC" Then
Sheet1.Rows(x).Hidden = True
End If
Next
End Sub
The result is that it kinda works but I have to wait several seconds for the process to complete every time I type into a cell which is making the sheet almost unworkable. Any pointers would be appreciated.
Generally you want to build up a range of rows to hide within the loop and then afterwards hide that range separately. You can build the range to hide using he Union() function like so:
Option Explicit
Sub HideRows()
Dim mainRng As Range
Set mainRng = Range("A2:A" & Range("A" & Rows.count).End(xlUp).Row)
Dim unionRng As Range
Dim i As Long
For i = mainRng.Row To mainRng.Row + mainRng.Rows.count - 1
If Cells(i, 1).Value2 = "HC" Then
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, Cells(i, 1))
Else
Set unionRng = Cells(i, 1)
End If
End If
Next i
If Not unionRng Is Nothing Then unionRng.EntireRow.Hidden = True
End Sub
Sometimes when you want to update too many things at once, the UI becomes a bit unresponsive.
I've found that disabling UI updates while doing those changes, speeds things up by an order of magnitude:
Sub XXX()
...
On Error GoTo EH
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.StatusBar = "I'm working on it..."
' do lots of changes in cells, rows, sheets...
' Undo the accel changes:
CleanUp:
On Error Resume Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.StatusBar = False
Exit Sub
EH:
' Do error handling
MsgBox "Error found: " & Err.Description
GoTo CleanUp
End Sub
See https://learn.microsoft.com/en-us/office/vba/api/excel.application.screenupdating
and Effect of Screen Updating
Related
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
I'm trying to create an Excel log file using VBA. The idea is that I have columns named Tasks and By and every time a user inputs a certain task in the column cell, the cell next to it (the By column cell) would display his user name as shown in the screenshot.
I have finished the application but every time I try to test it it gives me different results and none of these results are the intended so if some one would pay a look at the code I would be glad.
Private Sub Workbook_Open()
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.CalculateBeforeSave = False
Dim serialRange As Excel.Range
Set serialRange = ActiveSheet.Range("A2:A200")
Dim taskRange As Excel.Range
Set taskRange = ActiveSheet.Range("B2:B200")
For Each cell In serialRange
Dim rownumber As Integer
rownumber = ActiveCell.Row
Dim cellValue As Integer
cellValue = cell.Value
If (ActiveSheet.Range("A1").Value = "") Then
cellValue = Null
Else
cellValue = rownumber - 1
End If
Next
For Each cell In taskRange
If (cell.Value = "") Then
cell.Value = ""
Else
ActiveCell.Offset(2).Value = Environ("username")
End If
Next
Application.ScreenUpdating = True
ActiveWorkbook.Save
Application.EnableEvents = True
Application.CalculateBeforeSave = True
Application.Calculation = xlCalculationManual
End Sub
couple of issues I see with the code:
The code only runs when workbook is opened. If that is by design then fine, I moved the code to Workbook_SheetCalculate to test it
Using ActiveCell and ActiveSheet can cause some real issues. For instance, when I test the code, it puts my UserName in the cell 2 cels down from whatever cell is active, not in the column next to the cell it is evaluating. This is due to the use of ActiveCell when you SHOULD be using cell and the offset should be (0,1) not (2)
For Each cell In taskRange
If (cell.Value = "") Then
cell.Value = ""
Else
cell.Offset(0, 1).Value = Environ("username")
End If
Next
You never turn calculation back to automatic (in the last section of your code, you set it to manual, which you did in the first part of your code)
Saving the workbook should occur after you re-enable all of the event handling
Application.EnableEvents = true
Application.ScreenUpdating = true
Application.Calculation =xlCalculationAutomatic
Application.CalculateBeforeSave = true
ActiveWorkbook.Save
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
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:
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