VBA - Speed of Hiding/Unhiding Row as a Worksheet Event - excel

I'm struggling with the speed at which the following VBA code executes.
The goal of this code is to activate whenever "C4" changes, and then scan column "R" for the value 'Y'. If there's a 'Y', then it hides the row, and if not, it unhides the row. The code works, it's just not speedy - for 500 rows, it can take 30 or more seconds every time I change the value of "C4".
Does anyone have any suggestions to improve the speed at which this code executes? Or another method of accomplishing this?
Thanks for taking a look.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim L As Long
Dim r As Range
L = Cells(Rows.Count, "R").End(xlUp).Row
If Not Intersect(Target, Range("C4")) Is Nothing Then
For Each r In Range("R2:R" & L)
If r.Value = "Y" Then
Rows(r.Row).Hidden = True
Else
Rows(r.Row).Hidden = False
End If
Next
End If
End Sub
In attempting to apply the suggestion below - use Union() - I have come up with the below, not working, code. Any help would be greatly appreciated.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim L As Long
Dim r As Range
Dim RowsToHide As Range
Dim RowsToUnhide As Range
L = Cells(Rows.Count, "R").End(xlUp).Row
If Not Intersect(Target, Range("C4")) Is Nothing Then
For Each r In Range("R2:R" & L)
If r.Value = "Y" Then
RowsToHide = Union(RowsToHide, r.Row)
Else
RowsToUnhide = Union(RowsToUnhide, r.Row)
End If
Next
End If
RowsToHide.Hidden = True
RowsToUnhide.Hidden = False
End Sub

Adding Application.EnableEvents = False at the beginning of the code then turning back to true will help, Also using Applciation.ScreenUpdating = False should help as well.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim L As Long
Dim r As Range
Application.EnableEvents = False
Application.ScreenUpdating = False
L = Cells(Rows.Count, "R").End(xlUp).Row
If Not Intersect(Target, Range("C4")) Is Nothing Then
For Each r In Range("R2:R" & L)
If r.Value = "Y" Then
Rows(r.Row).Hidden = True
Else
Rows(r.Row).Hidden = False
End If
Next
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

There are several techniques that will help speed this up
Writing to .Hidden is much slower than reading it. So check if the row is already hidden or showing before setting Hidden
Collect the rows to Hide or Show into a range (Union) and Hide/Show tehm in one go.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Dim rngCheck As Range
Dim rngHide As Range, rngShow As Range
Application.ScreenUpdating = False
If Not Intersect(Target, Me.Range("C1")) Is Nothing Then
Set rngCheck = Me.Range(Me.Cells(1, "R"), Me.Cells(Me.Rows.Count, "R").End(xlUp))
For Each r In rngCheck.Cells
If r.Value2 = "Y" Then
If Not r.EntireRow.Hidden Then
If rngHide Is Nothing Then
Set rngHide = r.EntireRow
Else
Set rngHide = Union(rngHide, r.EntireRow)
End If
End If
Else
If r.EntireRow.Hidden Then
If rngShow Is Nothing Then
Set rngShow = r.EntireRow
Else
Set rngShow = Union(rngShow, r.EntireRow)
End If
End If
End If
Next
End If
If Not rngHide Is Nothing Then
rngHide.EntireRow.Hidden = True
End If
If Not rngShow Is Nothing Then
rngShow.EntireRow.Hidden = False
End If
Application.ScreenUpdating = True
End Sub

Related

Combining Not Intersect, Target.Parent.Range and Worksheets.Cells

I am aiming to add VBA that hides or shows rows depending on whether a user clicks on a specific cell that needs to loop many times.
I was wondering how to possibly combine Target.Parent.Range with Worksheet.Cells so that I can write a loop for it rather than repeating the code multiple times. The below code works fine but seems pretty inefficient:
'Hide1
If (ActiveSheet.Name = "Dashboard") And Not Intersect(Target, Target.Parent.Range("G38")) Is Nothing Then
If Rows("40:47").EntireRow.Hidden = True Then
Rows("40:47").EntireRow.Hidden = False
Range("G38").Value = "Hide"
ActiveSheet.Range("A1").Select
Else
Rows("40:47").EntireRow.Hidden = True
Range("G38").Value = "Show"
ActiveSheet.Range("A1").Select
End If
End If
'Hide2
If (ActiveSheet.Name = "Dashboard") And Not Intersect(Target, Target.Parent.Range("G48")) Is Nothing Then
If Rows("50:57").EntireRow.Hidden = True Then
Rows("50:57").EntireRow.Hidden = False
Range("G48").Value = "Hide"
ActiveSheet.Range("A1").Select
Else
Rows("50:57").EntireRow.Hidden = True
Range("G48").Value = "Show"
ActiveSheet.Range("A1").Select
End If
End If
This will need to be repeated 10's of times as buttons are located at similar intervals down the sheet, so looping makes the most sense. Any help would be of great help as my attempts to combine the two functions have failed thus far.
Your code could be shortened to this
Private Sub Worksheet_Change(ByVal Target As Range)
Dim buttonRng As Range, hideRng As Range
Application.EnableEvents = False
Set buttonRng = Target
' Add in your ranges into this If statement
If Not Intersect(Target, Me.Range("G38")) Is Nothing Then
Set hideRng = Me.Rows("40:47")
ElseIf Not Intersect(Target, Me.Range("G48")) Is Nothing Then
Set hideRng = Me.Rows("50:57")
Else
Set hideRng = Nothing
End If
If Not hideRng Is Nothing Then
With hideRng
.Hidden = Not .Hidden
End With
buttonRng.Value2 = IIf(buttonRng.Value2 = "Show", "Hide", "Show")
End If
Application.EnableEvents = True
End Sub
You could add an additional sheet in with a list of the button location addresses and the range for them to hide.
You will need to set column B to text
and then use the following code
Private Sub Worksheet_Change(ByVal Target As Range)
Dim buttonRng As Range, hideRng As Range
Application.EnableEvents = False
Set buttonRng = Target
With Sheets("Button Hide Range").Columns(1)
Set hideRng = .Find(Target.Address(False, False))
End With
If Not hideRng Is Nothing Then
With Me.Rows(hideRng.Offset(0, 1).Value2)
.Hidden = Not .Hidden
End With
buttonRng.Value2 = IIf(buttonRng.Value2 = "Show", "Hide", "Show")
End If
Application.EnableEvents = True
End Sub
This sheet can then be hidden or set to xlVeryHidden if desired so it is not viewable by the end user.
Or if all of the rows to be hidden are the same offset away from the buttons you could use
Private Sub Worksheet_Change(ByVal Target As Range)
Dim buttonRng As Range
Dim i As Long
Application.EnableEvents = False
' i = row of first button to row of last button. Assuming each button is 10 rows apart from the previous
For i = 38 To 78 Step 10
If buttonRng Is Nothing Then
Set buttonRng = Me.Range("G" & i)
Else
Set buttonRng = Union(buttonRng, Me.Range("G" & i))
End If
Next i
If Not Intersect(Target, buttonRng) Is Nothing Then
' Assuming rows to be hidden are starts 2 rows away from button and ends 9 rows away
With Me.Rows(Target.Offset(2).Row & ":" & Target.Offset(9).Row)
.Hidden = Not .Hidden
End With
Target.Value2 = IIf(Target.Value = "Show", "Hide", "Show")
End If
Application.EnableEvents = True
End Sub

VBA Worksheet_Change how to hide rows that got certain value in it

Guys,
can you help me with my problem.
What I need to do is to make code, that will HIDE entire row, if for example value in B10 will be = 100.
Thanks in advance
Try something like this
If Range("B10").Value = 100 Then
Range("B10").EntireRow.Hidden = True
End If
I think I solved my problem.
Used this (not sure if there is anything unnecessary):
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastRow As Long, c As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
LastRow = Cells(Cells.Rows.Count, "B").End(xlUp).Row
On Error Resume Next
For Each c In Range("B1:B" & LastRow)
If c.Value = 100 Then
c.EntireRow.Hidden = True
ElseIf c.Value <> 100 Then
c.EntireRow.Hidden = False
End If
Next
On Error GoTo 0
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

Excel VBA script for finding specific text

So I'm adding a picture so you can see exactly what I need it to do -Excel sheet picture
So I have this script:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, G, L, N As Range, Inte As Range, r As Range
Set A = Range("F:F,K:K,M:M")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Inte
If r.Offset(0, 1).Value = "" Then
r.Offset(0, 1).Value = Date
End If
Next r
Application.EnableEvents = True
End Sub
We will talk about only what we see in the picture: so now when I write anything in column F it gives the date in column G, I want that it will give the date only if I write "Ja" (Yes in German) or "Yes"
Simple is that. I tried to find any "if" commands for it but none of mine worked.
Hope you can help me with that
Thanks!
Daniel
Here is a better practice to achieve that also you need to set Application.EnableEvents back to True when you are existing the method for the next time the event will be raised, also its not bad to make some "house keeping" and use error catch if something goes wrong:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ende
Application.EnableEvents = False
Set A = Range("F:F,K:K,M:M")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then
Application.EnableEvents = True
Exit Sub
End If
For Each cel In Target
r = cel.Row
c = cel.Column
If Trim(LCase(Cells(r, c))) = "yes" Or Trim(LCase(Cells(r, c))) = "ja" Then
Cells(r, c + 1) = Format(Date, "dd.MM.yyyy")
Else
' do something else
End If
Next
ende:
Application.EnableEvents = True
End Sub
What about this?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim rng As Range
Set rng = Range("F:F,K:K,M:M")
On Error GoTo SkipError
Application.EnableEvents = False
If Not Intersect(Target, rng) Is Nothing Then
For Each cell In Target
If LCase(VBA.Trim(cell.Value)) = "yes" Then
cell.Offset(0, 1) = Date
End If
Next cell
End If
SkipError:
Application.EnableEvents = True
End Sub

Excel VBA deleting rows based on an if statement (speed up)

I am deleting rows based on the value in column P.
Cells in column P have an if statement: IF(K<10,0,1)
If the value in column P is 0, then the row needs to be deleted.
I am using the following macro which works but takes quite long.
I would like to beable to process about 10000 rows.
It would be much appreciated if I could have some suggestions on speeding up this code.
[I had tried using this if statement: IF(K<10,"",1)
And then deleting rows using SpecialCells(XlCellTypeBlanks) but the the cells are not interpreted as blank , due to the presence of the formula I presume. ]
Sub RemoveBlankRows()
Application.ScreenUpdating = False
'PURPOSE: Deletes any row with 0 cells located inside P
'Reference: www.TheSpreadsheetGuru.com
Dim rng As Range
Dim blankrng As Range
Dim cell As Range
'Store blank cells inside a variable
'On Error GoTo NoBlanksFound
Set rng = Range("P2:P30000") '.SpecialCells(xlCellTypeBlanks)
'On Error GoTo 0
For Each cell In rng
If cell.Value = 0 Then
cell.EntireRow.Delete
'Value = ""
End If
Next
Application.ScreenUpdating = True
End Sub
This looks for 0 and avoids blanks:
Sub RowKiller()
Dim rKill As Range, r As Range, rng As Range
Set rng = Range("P2:P30000")
Set rKill = Nothing
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
For Each r In rng
If r.Value = 0 And r.Value <> "" Then
If rKill Is Nothing Then
Set rKill = r
Else
Set rKill = Union(rKill, r)
End If
End If
Next r
If Not rKill Is Nothing Then rKill.EntireRow.Delete
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
This is only demo code. Tailor it to meet your needs.

Clear the contents of columns B to F if cell A is empty

I have a worksheet with values depending on Cell A. If a row in column A contains a value then cells from Columns B through H will be changed accordingly.
If Cell of Column A is empty I want to reset the cells from columns D through F.
I wrote down the following VBA Code
Private Sub Worksheet_Change(ByVal Target As Range)
Dim n As Integer
For n = 5 To 75
Application.EnableEvents = False
If VarType(Cells(n, 1)) = vbEmpty Then
Cells(n, 4).ClearContents
Cells(n, 5).ClearContents
Cells(n, 6).ClearContents
Application.EnableEvents = True
End If
Next n
End Sub
The "FOR" Loop is annoying, and making the Excel to pause for 1 second or more after any entry to any Cell, can anyone help me correct the above code to do what I need to do without the "FOR" loop.
You are using a Worksheet_Change event and you iterating through 70 rows each time something changes.. this is a bad approach for this kind of problem and that's why there is a delay.
Instead, try
Private Sub Worksheet_Change(ByVal Target As Range)
Dim n As Long
If Target.Column = 1 Then
If IsEmpty(Cells(Target.Row, 1)) Then
Range("B" & Target.Row & ":F" & Target.Row).ClearContents
End If
End If
End Sub
this will only clear the cells if you remove a value from column A => when cell in column A is empty
Try this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
If Mid(Target.Address(1, 1), 1, 2) = "$A" Then
If Target.Cells(1, 1).Value = "" Then
For i = 4 To 6
Target.Cells(1, i).Value = ""
Next i
End If
End If
End Sub
Give this a try:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rLook As Range, r As Range, Intr As Range
Set rLook = Range("A5:A75")
Set Intr = Intersect(rLook, Target)
If Intr Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Intr
If r.Value = "" Then
rw = r.Row
Range("D" & rw & ":F" & rw).ClearContents
End If
Next r
Application.EnableEvents = True
End Sub
It should have minimal impact on timing.
Use a range object.
The following line of code will print the address of the Range we'll use to clear the contents. The first cells call gets the upper left corner of the range, the second cells call gets the lower right corner of the range.
Private Sub test()
Debug.Print Range(Cells(5, 4), Cells(75, 6)).Address
End Sub
We apply this to your code like this:
Private Sub Worksheet_Change(ByVal Target As Range)
If VarType(Cells(Target.Row, 1)) = vbEmpty Then
Application.EnableEvents = False
Range(Cells(Target.Row, 4), Cells(Target.Row, 6)).ClearContents
Application.EnableEvents = True
End If
End Sub
One final sidenote: You should use an error handler to make sure events are always enabled when the sub exits, even if an error occurs.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ErrHandler
If VarType(Cells(Target.Row, 1)) = vbEmpty Then
Application.EnableEvents = False
Range(Cells(Target.Row, 4), Cells(Target.Row, 6)).ClearContents
End If
ExitSub:
Application.EnableEvents = True
Exit Sub
ErrHandler:
MsgBox "Oh Noes!", vbCritical
Resume ExitSub
End Sub
You should disable events and cater for multiple cells when using the Change event.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = Intersect(Columns("A"), Target)
If rng1 Is Nothing Then Exit Sub
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
For Each rng2 In rng1.Cells
If IsEmpty(rng2.Value) Then rng2.Offset(0, 1).Resize(1, 5).ClearContents
Next
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
For those that need to have data entered in one cell cleared (in a column) when there's a change in another column use this, which is a modification of Gary's Student.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rLook As Range, r As Range, Intr As Range
Set rLook = Range("D:D")
Set Intr = Intersect(rLook, Target)
If Intr Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Intr
If r.Value = "" Then
rw = r.Row
Range("L:L").ClearContents
End If
Next r
Application.EnableEvents = True
End Sub

Resources