I have written the below code to cycle through my worksheets as a kind of slideshow to use in a sales department. The code works perfectly when I step through in debug mode, however when I run the macro it only works intermittently, occasionally getting to the selecting of the worksheets without having reactivated the screen updating application function.
Here is the code I have created so far:
Sub Runshow()
Dim ws As Worksheet
On Error GoTo exit_
Application.EnableCancelKey = xlErrorHandler
For Each ws In ThisWorkbook.Worksheets
ws.Protect
Next
Application.DisplayFullScreen = True
Application.DisplayFormulaBar = False
ActiveWindow.DisplayWorkbookTabs = False
ActiveWindow.DisplayHeadings = False
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHorizontalScrollBar = False
ActiveWindow.DisplayVerticalScrollBar = False
Application.Calculation = xlManual
Let y = 0
Do Until y = 80
Application.ScreenUpdating = False
Workbooks.Open("c:\users\admin\downloads\crm.xlsx").Activate
Application.Calculate
ActiveWorkbook.Close savechanges = False
Application.ScreenUpdating = True
ThisWorkbook.Activate
Let x = 0
Do Until x = 23
For Each ws In ActiveWorkbook.Worksheets
ws.Select
Application.Wait (Now + TimeValue("00:00:10"))
x = x + 1
Next
Loop
y = y + 1
Loop
exit_:
For Each ws In ThisWorkbook.Worksheets
ws.Unprotect
Next
Application.DisplayFullScreen = False
Application.DisplayFormulaBar = True
ActiveWindow.DisplayWorkbookTabs = True
ActiveWindow.DisplayGridlines = True
ActiveWindow.DisplayHorizontalScrollBar = True
ActiveWindow.DisplayVerticalScrollBar = True
Application.Calculation = xlAutomatic
End Sub
I put together some simple code that does something similar, and works well. You can build out from here - ask any questions if there's anything you don't understand.
Sub Slideshow()
Dim ws As Worksheet
PrepareView True
For Each ws In ThisWorkbook.Worksheets
ws.Activate
Application.Wait (Now + TimeValue("00:00:10"))
Next ws
PrepareView False
End Sub
Function PrepareView(status As Boolean)
If status = True Then
ActiveWindow.DisplayWorkbookTabs = False
ActiveWindow.DisplayHeadings = False
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHorizontalScrollBar = False
ActiveWindow.DisplayVerticalScrollBar = False
ElseIf status = False Then
Application.DisplayFullScreen = False
Application.DisplayFormulaBar = True
ActiveWindow.DisplayWorkbookTabs = True
ActiveWindow.DisplayGridlines = True
ActiveWindow.DisplayHorizontalScrollBar = True
ActiveWindow.DisplayVerticalScrollBar = True
End If
End Function
Related
The following code makes a list of sheets:
Sub Listofcontent()
Dim objSheet As Worksheet
Dim intRow As Integer
Dim strCol As Integer
Dim GCell As Range
SearchText = "Content"
Set GCell = Worksheets("Front page").Cells.Find(SearchText).Offset(2, 0)
GCell.End(xlDown).ClearContents
intRow = GCell.Row
strCol = GCell.Column
For Each objSheet In ActiveWorkbook.Sheets
ActiveWorkbook.Worksheets("Front page").Hyperlinks.Add Anchor:=ActiveWorkbook.Worksheets("Front page").Cells(intRow, strCol), Address:="", SubAddress:= _
"'" & objSheet.name & "'!A1", TextToDisplay:=objSheet.name
With ActiveWorkbook.Worksheets("0.0 Forside").Cells(intRow, strCol).Font
.name = "Calibri"
.FontStyle = "Normal"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
intRow = intRow + 1
Next objSheet
End Sub
It works now. Thanks. However, I want it to run whenever a sheet is added, deleted, renamed, moved, copied. I added this to the workbook code pane:
Private Sub Workbook_NewSheet(ByVal Sh As Object)
Application.EnableEvents = False
Listofcontent
Application.EnableEvents = True
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Application.EnableEvents = False
Listofcontent
Application.EnableEvents = True
End Sub
Change this
For Each objSheet In ActiveWorkbook.Sheets.Count
To
For Each objSheet In ActiveWorkbook.Sheets
I'm having trouble adding another function in that macro I used to activate or deactivate columns in a Excel Workbook we are using at work. I'm getting the Out of stack space error when running it just adding one of the following function.
Mostly, I've used an If( ;1;0) to manage the activation part and an If(;TRUE;FALSE) for the locked/unlocked part. The function I want to had is based on the same idea using a verification code to Clearcontents of a cell and locked it. If the verification code is false, then, I want the cell to be unlocked so the user can write the value. Here is the code line I want to had times 15 as already done for the locked, unlocked function.
If Range("AS16") = "Vrai" Then
Range("AA16").ClearContents
Range("AA16").Locked = True
Else:
Range("AA16").Locked = False
End If
Here is the code I'm using right now.
Private Sub Worksheet_Change(ByVal Target As Range)
ActiveSheet.Unprotect ("Francis")
Dim Cell As Range
Set Cell = ActiveCell
Application.ScreenUpdating = False
For Each cellule In Range("S50:X50")
If cellule.Value = "1" Then cellule.EntireColumn.Hidden = False
Next cellule
For Each cellule In Range("S50:X50")
If cellule.Value = "0" Then cellule.EntireColumn.Hidden = True
Next cellule
For Each cellule In Range("I50:J50")
If cellule.Value = "1" Then cellule.EntireColumn.Hidden = False
Next cellule
For Each cellule In Range("I50:J50")
If cellule.Value = "0" Then cellule.EntireColumn.Hidden = True
Next cellule
If Range("AR16") = "Vrai" Then
Range("K16").Locked = False
Range("O16").Locked = False
Else:
Range("K16").Locked = True
Range("O16").Locked = True
End If
If Range("AR18") = "Vrai" Then
Range("K18").Locked = False
Range("O18").Locked = False
Else:
Range("K18").Locked = True
Range("O18").Locked = True
End If
If Range("AR20") = "Vrai" Then
Range("K20").Locked = False
Range("O20").Locked = False
Else:
Range("K20").Locked = True
Range("O20").Locked = True
End If
If Range("AR22") = "Vrai" Then
Range("K22").Locked = False
Range("O22").Locked = False
Else:
Range("K22").Locked = True
Range("O22").Locked = True
End If
If Range("AR24") = "Vrai" Then
Range("K24").Locked = False
Range("O24").Locked = False
Else:
Range("K24").Locked = True
Range("O24").Locked = True
End If
If Range("AR26") = "Vrai" Then
Range("K26").Locked = False
Range("O26").Locked = False
Else:
Range("K26").Locked = True
Range("O26").Locked = True
End If
If Range("AR28") = "Vrai" Then
Range("K28").Locked = False
Range("O28").Locked = False
Else:
Range("K28").Locked = True
Range("O28").Locked = True
End If
If Range("AR30") = "Vrai" Then
Range("K30").Locked = False
Range("O30").Locked = False
Else:
Range("K30").Locked = True
Range("O30").Locked = True
End If
If Range("AR32") = "Vrai" Then
Range("K32").Locked = False
Range("O32").Locked = False
Else:
Range("K32").Locked = True
Range("O32").Locked = True
End If
If Range("AR34") = "Vrai" Then
Range("K34").Locked = False
Range("O34").Locked = False
Else:
Range("K34").Locked = True
Range("O34").Locked = True
End If
If Range("AR36") = "Vrai" Then
Range("K36").Locked = False
Range("O36").Locked = False
Else:
Range("K36").Locked = True
Range("O36").Locked = True
End If
If Range("AR38") = "Vrai" Then
Range("K38").Locked = False
Range("O38").Locked = False
Else:
Range("K38").Locked = True
Range("O38").Locked = True
End If
If Range("AR40") = "Vrai" Then
Range("K40").Locked = False
Range("O40").Locked = False
Else:
Range("K40").Locked = True
Range("O40").Locked = True
End If
If Range("AR42") = "Vrai" Then
Range("K42").Locked = False
Range("O42").Locked = False
Else:
Range("K42").Locked = True
Range("O42").Locked = True
End If
If Range("AR44") = "Vrai" Then
Range("K44").Locked = False
Range("O44").Locked = False
Else:
Range("K44").Locked = True
Range("O44").Locked = True
End If
Application.ScreenUpdating = True
Application.Goto Cell
'ActiveSheet.Protect Password:="Francis"
End Sub
Thanks a lot for your help.
Have a nice day!
You typically don't want to have performance-expensive code running in that specific handler. Worksheet_Change gets invoked every time a cell changes... and that includes changing a cell's Locked property value.
So that's how you run out of stack space: your handler is modifying cells' Locked state, which triggers the Worksheet_Change event, which modifies cells' Locked state, which triggers the Worksheet_Change event, which modifies cells' Locked state, which triggers the Worksheet_Change event, which... which eventually blows the call stack.
So prevent this accidental recursion, you need to prevent Excel from firing worksheet events when you're handling one:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo CleanFail
Application.EnableEvents = False
'do stuff
CleanExit:
Application.EnableEvents = True
Exit Sub
CleanFail:
'handle errors here...
Resume CleanExit
End Sub
As for simplifying the code, that's more of a mandate for Code Review Stack Exchange, once your code works as intended.
If any C# dev is reading this, this particular situation now has an up-for-grabs issue on Rubberduck's GitHub repository: #3109 Prevent accidental recursion in Worksheet_Change and Workbook_SheetChange handlers; once that inspection is implemented, Rubberduck will be able to warn you when you handle Worksheet_Change without disabling application events.
The Out of stack error is caused by the Change event, as noted by #Mat
Try this version which also turns the events off and on
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cellule As Range, r As Long, isVrai As Boolean
ActiveSheet.Unprotect "Francis"
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For Each cellule In Union(Range("I50:J50"), Range("S50:X50"))
With cellule
Select Case .Value2
Case "1": .EntireColumn.Hidden = False
Case "0": .EntireColumn.Hidden = True
End Select
End With
Next
For r = 16 To 44 Step 2
isVrai = (Range("AR" & r).Value2 = "Vrai")
Range("K" & r).Locked = Not isVrai
Range("O" & r).Locked = Not isVrai
If isVrai Then Range("AR" & r).ClearContents
Next
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'ActiveSheet.Protect Password:="Francis"
End Sub
This section can be simplified:
For Each cellule In Range("S50:X50")
If cellule.Value = "1" Then cellule.EntireColumn.Hidden = False
Next cellule
For Each cellule In Range("S50:X50")
If cellule.Value = "0" Then cellule.EntireColumn.Hidden = True
Next cellule
For Each cellule In Range("I50:J50")
If cellule.Value = "1" Then cellule.EntireColumn.Hidden = False
Next cellule
For Each cellule In Range("I50:J50")
If cellule.Value = "0" Then cellule.EntireColumn.Hidden = True
Next cellule
To the following (however, note that this will unhide any non-zero values).
For Each cellule in Range("S50:X50")
cellule.EntireColumn.Hidden = (cellule.Value = "0")
Next
For Each cellule in Range("I50:J50")
cellule.EntireColumn.Hidden = (cellule.Value = "0")
Next
And this section:
If Range("AR16") = "Vrai" Then
Range("K16").Locked = False
Range("O16").Locked = False
Else:
Range("K16").Locked = True
Range("O16").Locked = True
End If
If Range("AR18") = "Vrai" Then
Range("K18").Locked = False
Range("O18").Locked = False
Else:
Range("K18").Locked = True
Range("O18").Locked = True
End If
....
Can be simplified using a loop over Range("AR16:AR44")
For Each cellule in Range("AR16:AR44") Step 2
cellule.Offset(,-33).Locked = (cellule.Value = "Vrai")
cellule.Offset(,-29).Locked = (cellule.Value = "Vrai")
Next
If you run the code below in Excel 2013 or Excel 2016 then it will cause Excel to flicker.
Does anyone have any suggestions on how to stop the flickering?
Sub FlickerTestMain()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
FlickerTestHelper
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
Sub FlickerTestHelper()
Dim currentWorkbook As Workbook, newWorkbook As Workbook
Set currentWorkbook = Application.ActiveWorkbook
Set newWorkbook = Application.Workbooks.Add(xlWBATWorksheet)
newWorkbook.Windows(1).Visible = False
currentWorkbook.Activate
newWorkbook.Worksheets(1).Range("a1:Z10000").Value2 = "test"
newWorkbook.Close False
End Sub
So I am attempting to hide rows in Excel 2013 using VBA based a several different conditions:
If title of section is "Unused" hide section. Each section is a named range to make this easier.
If row is part of the "Cblank" named range hide it.
Now for the hard part -- For each Cell in Range("CNonTest") if C.Value = "" and C.Columns(41).Value = "" Then hide them.
Range("CNonTest") is in Col C the extra column that should be check is Col AQ.
For added difficulty I need this macro to run every time any 1 of 8 different validation boxes changes.
Below is the code I currently have:
Sub CompHide()
With Sheets("Comparison").Cells
.EntireRow.Hidden = False
If Range("C9").Value = "Unused" Then
Range("CMarket1").EntireRow.Hidden = True
End If
If Range("C115").Value = "Unused" Then
Range("CMarket2").EntireRow.Hidden = True
End If
If Range("C221").Value = "Unused" Then
Range("CMarket3").EntireRow.Hidden = True
End If
If Range("C329").Value = "Unused" Then
Range("CMarket4").EntireRow.Hidden = True
End If
If Range("C437").Value = "Unused" Then
Range("CMarket5").EntireRow.Hidden = True
End If
If Range("C545").Value = "Unused" Then
Range("CMarket6").EntireRow.Hidden = True
End If
If Range("C653").Value = "Unused" Then
Range("CMarket7").EntireRow.Hidden = True
End If
If Range("C761").Value = "Unused" Then
Range("CMarket8").EntireRow.Hidden = True
End If
If Range("C869").Value = "Unused" Then
Range("CMarket9").EntireRow.Hidden = True
End If
If Range("C977").Value = "Unused" Then
Range("CMarket10").EntireRow.Hidden = True
End If
For Each C In Range("CNonTest")
If C.Value = "" And C.Columns(41).Value = "" Then
C.EntireRow.Hidden = True
End If
Next
Range("CBlank").EntireRow.Hidden = True
End With
End Sub
Then on the Sheet I have this code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Me.Range("A4")) Is Nothing _
Or _
Intersect(Target, Me.Range("D4")) Is Nothing _
Or _
Intersect(Target, Me.Range("G4")) Is Nothing _
Or _
Intersect(Target, Me.Range("K4")) Is Nothing _
Or _
Intersect(Target, Me.Range("AO4")) Is Nothing _
Or _
Intersect(Target, Me.Range("AR4")) Is Nothing _
Or _
Intersect(Target, Me.Range("AU4")) Is Nothing _
Or _
Intersect(Target, Me.Range("AY4")) Is Nothing _
Then Exit Sub
Application.EnableEvents = False 'to prevent endless loop
Application.ScreenUpdating = False
Call CompHide
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
For the Sheet Code I have also tried this to no avail
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Me.Range("A4")) Is Nothing Then Exit Sub
Application.EnableEvents = False 'to prevent endless loop
Application.ScreenUpdating = False
Call CompHide
Application.ScreenUpdating = True
Application.EnableEvents = True
If Intersect(Target, Me.Range("D4")) Is Nothing Then Exit Sub
Application.EnableEvents = False 'to prevent endless loop
Application.ScreenUpdating = False
Call CompHide
Application.ScreenUpdating = True
Application.EnableEvents = True
If Intersect(Target, Me.Range("G4")) Is Nothing Then Exit Sub
Application.EnableEvents = False 'to prevent endless loop
Application.ScreenUpdating = False
Call CompHide
Application.ScreenUpdating = True
Application.EnableEvents = True
If Intersect(Target, Me.Range("K4")) Is Nothing Then Exit Sub
Application.EnableEvents = False 'to prevent endless loop
Application.ScreenUpdating = False
Call CompHide
Application.ScreenUpdating = True
Application.EnableEvents = True
If Intersect(Target, Me.Range("AO4")) Is Nothing Then Exit Sub
Application.EnableEvents = False 'to prevent endless loop
Application.ScreenUpdating = False
Call CompHide
Application.ScreenUpdating = True
Application.EnableEvents = True
If Intersect(Target, Me.Range("AR4")) Is Nothing Then Exit Sub
Application.EnableEvents = False 'to prevent endless loop
Application.ScreenUpdating = False
Call CompHide
Application.ScreenUpdating = True
Application.EnableEvents = True
If Intersect(Target, Me.Range("AU4")) Is Nothing Then Exit Sub
Application.EnableEvents = False 'to prevent endless loop
Application.ScreenUpdating = False
Call CompHide
Application.ScreenUpdating = True
Application.EnableEvents = True
If Intersect(Target, Me.Range("AY4")) Is Nothing Then Exit Sub
Application.EnableEvents = False 'to prevent endless loop
Application.ScreenUpdating = False
Call CompHide
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
This code all seems to work fine and when I step through CompHide using F8 it works perfectly. So I am thinking the issue is from the code on the sheet itself. You will see a comment in that code that mentions to prevent endless loop that comment came from some hand me down code not quite sure what it is for but figured based on the comment I would leave it.
When I change a validation box it no longer hides the all the right things only some of them. Luckily I have not seen it hide something it was not suppose to yet. I say no longer because at first this code only looked at the first validation box but now it looks at all 8.
Some adjustments to your event handler:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
On Error GoTo haveError
Set rng = Application.Intersect(Target, Me.Range("A4,D4,G4,K4,AO4,AR4,AU4,AY4"))
If Not rng Is Nothing Then
Application.EnableEvents = False 'to prevent endless loop
Application.ScreenUpdating = False
CompHide
Application.EnableEvents = True
End If
Exit Sub
haveError:
'always re-enable events
' (screenupdating setting is not persistent)...
Application.EnableEvents = True
End Sub
and the other part:
Sub CompHide()
Dim sht As Worksheet, C As Range
Set sht = Sheets("Comparison")
sht.Rows.Hidden = False
SetRowVis "C9", "CMarket1"
SetRowVis "C115", "CMarket2"
'...and the rest
For Each C In sht.Range("CNonTest")
If C.Value = "" And C.EntireRow.Columns(43).Value = "" Then
C.EntireRow.Hidden = True
End If
Next
sht.Range("CBlank").EntireRow.Hidden = True
End Sub
'utility sub...
Sub SetRowVis(addr As String, rngName As String)
With Sheets("Comparison")
If .Range(addr).Value = "Unused" Then
.Range(rngName).EntireRow.Hidden = True
End If
End With
End Sub
1st, you have referencing issue on your CompHide Sub.
You need to fully reference all Range object call to the worksheet.
With Sheets("Comparison")
.Cells.EntireRow.Hidden = False
'Notice the dot in front of the Range object
If .Range("C9").Value = "Unused" Then .Range("CMarket1").EntireRow.Hidden = True
'Also notice that I used a one liner IF which I think is applicable for you
'Rest of your code go here
'.
'.
'.
End With
2nd, take a look on Tim's post. He beats me to it. :)
This is my first post, so if I need to make any changes, please let me know.
I've found a few examples of ways to optimize loops, but I cannot seem to apply any of them effectively to my code. What I'm trying to do is loop through about 170 cells in a single column, and hide or show the entire row based on whether the cell value is 0 or not.
I want the code to run each time I activate certain sheets. Right now this piece of code is taking about 4 seconds to run. It seems like it should be much faster than that! That's why I'm here for help.
Here is the code I'm using (FormatSheet returns a BOOLEAN where True means that it is okay to perform this code on this sheet and False means to skip performing this code on this sheet:
Private Sub mobjWb_SheetActivate(ByVal Sh As Object)
Dim r As Long
Dim z As Long
Dim varray As Variant
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
If Not FormatSheet(Sh) Then
Exit Sub
End If
Set varray = Range("$F$1", Cells(Rows.count, "F").End(x1up)).Value
For Each r In varray
z = r.Value
If z = 0 Then
Range("F" & r).EntireRow.Hidden = True
Else
Range("F" & r).EntireRow.Hidden = False
End If
Next r
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End Sub
With several very slight changes:
Sub qwerty()
Dim r As Range
Dim z As Long, N As Long
Dim varray As Range
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
N = Cells(Rows.Count, "F").End(xlUp).Row
Set varray = Range("F1:F" & N)
For Each r In varray
z = r.Value
If z = 0 Then
r.EntireRow.Hidden = True
Else
r.EntireRow.Hidden = False
End If
Next r
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End Sub
run quite rapidly
One thing that may speed up it a little bit.. I would not use z variable. You can do the same with existing r.
For Each r In varray
If r.Value = 0 Then
Range("F" & r).EntireRow.Hidden = True
Else
Range("F" & r).EntireRow.Hidden = False
End If
Next r
I think the quickest way could be to use autofilter. Set the autofilter with values <> 0 and voilĂ !