I have an Excel workbook which contains multiple sheets. I want to hide/unhide sheets based on cell values in Main sheet cells B3:B8. Values in Main sheet are changed by the user from pre-defined list.
Eg. If "A" exists in the "Config" column, then unhide sheet "A" in my workbook.
At the moment I have following code, which works, but looks
clunky, Excel flickers as the code runs every time a value is changed in "Config" column:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
Sheets("A").Visible = False
Sheets("B").Visible = False
Sheets("C").Visible = False
Sheets("D").Visible = False
For i = 3 To 8
If InStr(1, Cells(i, 2), "A") Then
Sheets("A").Visible = True
ElseIf InStr(1, Cells(i, 2), "B") Then
Sheets("B").Visible = True
ElseIf InStr(1, Cells(i, 2), "C") Then
Sheets("C").Visible = True
ElseIf InStr(1, Cells(i, 2), "D") Then
Sheets("D").Visible = True
End If
Next i
End Sub
I also tried to run this macro from a button, but it stops with first TRUE value (a sheet becomes unhidden).
I would use this method:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
Sheets("A").Visible = xlSheetHidden
Sheets("B").Visible = xlSheetHidden
Sheets("C").Visible = xlSheetHidden
Sheets("D").Visible = xlSheetHidden
Application.ScreenUpdating = False
For i = 3 To 8
If InStr(1, Cells(i, 2), "A") Then Sheets("A").Visible = xlSheetVisible
If InStr(1, Cells(i, 2), "B") Then Sheets("B").Visible = xlSheetVisible
If InStr(1, Cells(i, 2), "C") Then Sheets("C").Visible = xlSheetVisible
If InStr(1, Cells(i, 2), "D") Then Sheets("D").Visible = xlSheetVisible
Next i
Application.ScreenUpdating = True
End Sub
Another way to do this would be:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim RNG As Range, CL As Range
Dim WS As Worksheet
Application.ScreenUpdating = False
Set RNG = Sheets("Main").Range("B3:B8")
If Not Intersect(Target, RNG) Is Nothing Then
Application.ScreenUpdating = False
For Each WS In ThisWorkbook.Worksheets
If WS.Name <> "Main" Then
With RNG
Set CL = .Find(What:=WS.Name, LookIn:=xlValues, LookAt:=xlWhole)
If Not CL Is Nothing Then
WS.Visible = xlSheetVisible
Else
WS.Visible = xlSheetHidden
End If
End With
End If
Next WS
End If
Application.ScreenUpdating = True
End Sub
More versatile and more dynamic
EDIT: To also check if Target intersects with your lookup range to prevent triggering macro unwanted.
To help optimize the running and have it look better use Application.ScreenUpdating. It will reduce the flickering by not trying to repaint the scrren until the Sub has finished running. If the rest of the program runs with no issue it should be all you need
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
Sheets("A").Visible = False
Sheets("B").Visible = False
Sheets("C").Visible = False
Sheets("D").Visible = False
For i = 3 To 8
If InStr(1, Cells(i, 2), "A") Then
Application.ScreenUpdating = False
Sheets("A").Visible = True
ElseIf InStr(1, Cells(i, 2), "B") Then
Application.ScreenUpdating = False
Sheets("B").Visible = True
ElseIf InStr(1, Cells(i, 2), "C") Then
Application.ScreenUpdating = False
Sheets("C").Visible = True
Application.ScreenUpdating = False
ElseIf InStr(1, Cells(i, 2), "D") Then
Sheets("D").Visible = True
End If
Next i
Application.sScreenUpdating = True
End Sub
I also agree with 's comment. Ifs would be better. ElseIf assumes only one condition is the correct one when there could be multiple iterations.
edit:
Also a though: It looks like the way its set up you intend that any value between B3:B8 that has an "A" will show page "A". If you dedicate it differently B3 = "A" , B4="B" etc and so on, you can change the conditionals to If Target.Address = "$B$3" Then and have B# be the on/off to sheet"A" with any non-empty value.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
If Target.Address = "$B$3" Then
If IsEmpty(Sheet1.Range("B3")) = False Then
Sheets("A").Visible = True
Else
Sheets("A").Visible = False
End If
End If
''etc etc and so on
Application.ScreenUpdating = True
End Sub
Related
Having trouble executing both Worksheet_Change events correctly. Image below show my results, when modifying column B, column M does nothing. When modifying column L, column N updates as expected but only on row 2. Every other subsequent change to B or M results in N:2 updating to the current time again.
My desired outcome is that when Col B is updated I record a time stamp in Col M and the same when Col L updates that I get a time stamp in Col N.
Example of Excel Error
My current code is here:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim rng As Range
Dim rng2 As Range
If Not Intersect(Target, Columns("B"), Target.Parent.UsedRange) Is Nothing Then
On Error GoTo Safe_Exit
For Each rng In Intersect(Target, Columns("B"), Target.Parent.UsedRange)
If CBool(Len(rng.Value2)) And Not CBool(Len(rng.Offset(0, 11).Value2)) Then
rng.Offset(0, 11) = Now
ElseIf Not CBool(Len(rng.Value2)) And CBool(Len(rng.Offset(0, 11).Value2)) Then
rng.Offset(0, 11) = vbNullString
End If
Next rng
Application.EnableEvents = True
End If
ElseIf Not Intersect(Target, Columns("L"), Target.Parent.UsedRange) Is Nothing Then
On Error GoTo Safe_Exit
For Each rng2 In Intersect(Target, Columns("L"), Target.Parent.UsedRange)
If CBool(Len(rng2.Value2)) And Not CBool(Len(rng2.Offset(0, 2).Value2)) Then
rng2.Offset(0, 2) = Now
ElseIf Not CBool(Len(rng2.Value2)) And CBool(Len(rng2.Offset(0, 2).Value2)) Then
rng2.Offset(0, 2) = vbNullString
End If
Next rng2
Application.EnableEvents = True
End If
Safe_Exit:
End Sub
Mock-up, untested, change of code to simplify as you're doing the same actions in two spots:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim columnLetter as String
Select Case Target.Column
Case 2 'B
columnLetter = "M"
Case 12 'L
columnLetter = "N"
Case Else
Goto Safe_Exit
End Select
Dim loopRng as Range
For Each loopRng In Range(Cells(Target.Row, Target.Column),Cells(Target.End(xlDown).Row,Target.Column)
If IsEmpty(loopRng) = True And IsEmpty(Cells(loopRng.Row,columnLetter)) = False Then
Cells(loopRng.Row,columnLetter) = Now
ElseIf IsEmpty(loopRng) = False And IsEmpty(Cells(loopRng.Row,columnLetter)) = True Then
Cells(loopRng.Row,columnLetter) = vbNullString
End If
Next loopRng
'Columns(columnLetter).NumberFormat = "yyyy/mm/dd"
Application.EnableEvents = True
Safe_Exit:
Application.EnableEvents = True
End Sub
Note that the IsEmpty() = True is important... when using an If case, you need to specify for each condition, otherwise the implicit detection will fail.
Edit1: Removed Intersect from loop, whereas the range i've listed will need corrected... it at least references a specific range, now.
Edit2: Removing .Offset and working with specific column references in cells().
I tried this version of my original code and it started to work for some reason.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("B"), Target.Parent.UsedRange) Is Nothing Then
On Error GoTo Safe_Exit
Application.EnableEvents = False
Dim rng As Range
For Each rng In Intersect(Target, Columns("B"), Target.Parent.UsedRange)
If CBool(Len(rng.Value2)) And Not CBool(Len(rng.Offset(0, 11).Value2)) Then
rng.Offset(0, 11) = Now
ElseIf Not CBool(Len(rng.Value2)) And CBool(Len(rng.Offset(0, 11).Value2)) Then
rng.Offset(0, 11) = vbNullString
End If
Next rng
End If
If Not Intersect(Target, Columns("L"), Target.Parent.UsedRange) Is Nothing Then
On Error GoTo Safe_Exit
Application.EnableEvents = False
For Each rng In Intersect(Target, Columns("L"), Target.Parent.UsedRange)
If CBool(Len(rng.Value2)) And Not CBool(Len(rng.Offset(0, 2).Value2)) Then
rng.Offset(0, 2) = Now
ElseIf Not CBool(Len(rng.Value2)) And CBool(Len(rng.Offset(0, 2).Value2)) Then
rng.Offset(0, 2) = vbNullString
End If
Next rng
End If
Safe_Exit:
Application.EnableEvents = True
End Sub
I've got a sheet in which I'm trying to merge some cells based on CX cell value. CX cell is also dynamically locked/unlocked based on BX cell value. Although locking/unlocking works fine, I get 1004 error when I'm trying to merge cells with line:
Range(Cells(Target.Row, i), Cells(Target.Row + Target.Value - 1, i)).Merge
While code is below.
Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Not Intersect(Target, Range("B14:B50")) Is Nothing And Sh.Name <> "Dane" Then
Dim pass As String
pass = "" 'set the password. Otherwise, protection/unprotection is done without a pass
If Target.Cells.Count > 1 Then Exit Sub
ActiveSheet.Unprotect pass
If Target.Value = "Unlocked" Then
Target.Offset(0, 1).Locked = False
Else
Target.Offset(0, 1).Value = 0
Target.Offset(0, 1).Locked = True
End If
ActiveSheet.Protect pass
End If
If Not Intersect(Target, Range("C14:C50")) Is Nothing And Sh.Name <> "Dane" Then
Dim i As Long
Application.DisplayAlerts = False
For i = 1 To 8 Step 1
If i <> 6 And i <> 7 And Cells(Target.Row, i).MergeCells Then
Cells(Target.Row, i).UnMerge
End If
Next i
If Target.Value <> 0 Then
For i = 1 To 8 Step 1
If i <> 6 And i <> 7 Then
Range(Cells(Target.Row, i), Cells(Target.Row + Target.Value - 1, i)).Merge
End If
Next i
End If
Application.DisplayAlerts = True
End If
End Sub
Okay. So with #FaneDuru comments, I've been able to figure out the issue. Sheet protection was causing the problem, so I had to unprotect and reprotect sheet before for loops in second condition. Also, #FaneDuru advised to set EnableEvents = false there, to prevent any infinite loop issue. Below is the fixed code.
Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Not Intersect(Target, Range("B14:B50")) Is Nothing And Sh.Name <> "Dane" Then
Dim pass As String
pass = "" 'set the password. Otherwise, protection/unprotection is done without a pass
If Target.Cells.Count > 1 Then Exit Sub
ActiveSheet.Unprotect pass
If Target.Value = "Unlocked" Then
Target.Offset(0, 1).Locked = False
Else
Target.Offset(0, 1).Value = 0
Target.Offset(0, 1).Locked = True
End If
ActiveSheet.Protect pass
End If
If Not Intersect(Target, Range("C14:C50")) Is Nothing And Sh.Name <> "Dane" Then
Dim i As Long
Application.DisplayAlerts = False
Application.EnableEvents = False
ActiveSheet.Unprotect pass
For i = 1 To 8 Step 1
If i <> 6 And i <> 7 And Cells(Target.Row, i).MergeCells Then
Cells(Target.Row, i).UnMerge
End If
Next i
If Target.Value <> 0 Then
For i = 1 To 8 Step 1
If i <> 6 And i <> 7 Then
Range(Cells(Target.Row, i), Cells(Target.Row + Target.Value - 1, i)).Merge
End If
Next i
End If
ActiveSheet.Protect pass
Application.EnableEvents = True
Application.DisplayAlerts = True
End If
End Sub
However, I'm still wondering why I need to unprotect the sheet to edit unlocked range.
I have a Worksheet_change in which two events are checked (edits on cells of column C and edits on cells of column D). The problem is that an edit on column C's cells modify the value of column D's cells (and viceversa), so the Worksheet_change is triggered repeatedly and excel eventually crashes.
How can I avoid the problem but maintaining my functionality?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rgFound As Range
Dim defVal As Range
Dim currParam As Range
Dim currParamDict As Range
Set targ = Intersect(Target, Range("A:A"))
If Not targ Is Nothing Then
With Worksheets("FT_CASE_xx")
For Each defVal In .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Offset(, 1)
Set currParam = defVal.Offset(, -1)
Dim xlFirstChar As String
xlFirstChar = Left$(currParam, 1)
If xlFirstChar = "B" Then
Set rgFound = Worksheets("DEF_BOOLEAN").Range("A:A").Find(currParam.value)
defVal.Offset(, 1).Interior.Color = RGB(230, 230, 230)
defVal.Offset(, 1).Locked = True
defVal.Offset(, 2).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="TRUE,FALSE"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Else
Set rgFound = Worksheets("DEF_FLOAT").Range("A:A").Find(currParam.value)
defVal.Offset(, 1).Interior.ColorIndex = 0
defVal.Offset(, 1).Locked = False
defVal.Offset(, 2).Locked = False
defVal.Offset(, 1).NumberFormat = "0.000"
defVal.Offset(, 2).NumberFormat = "0.000"
defVal.Offset(, 3).NumberFormat = "0.000"
End If
If rgFound Is Nothing Then
Debug.Print "Name was not found."
Else
If xlFirstChar = "B" Then
Set currParamDict = rgFound.Offset(, 3)
Else
Set currParamDict = rgFound.Offset(, 5)
End If
defVal.value = currParamDict.value
End If
Next defVal
End With
Else
Set targ = Intersect(Target, Range("C:C"))
If Not targ Is Nothing Then
Dim coeffVal As Range
Dim currVal As Range
Dim RequestedVal As Range
With Worksheets("FT_CASE_xx")
For Each coeffVal In .Range("C2", .Range("C" & Rows.Count).End(xlUp))
Set currVal = coeffVal.Offset(, -1)
Set RequestedVal = coeffVal.Offset(, 1)
Set ParamName = coeffVal.Offset(, -2)
Dim xlFirstChar2 As String
xlFirstChar2 = Left$(ParamName, 1)
If ((xlFirstChar2 = "F") And (IsEmpty(coeffVal.value) = False)) Then
RequestedVal.value = coeffVal.value * currVal.value
End If
Next coeffVal
End With
Else
Set targ = Intersect(Target, Range("D:D"))
If Not targ Is Nothing Then
Dim coeffsVal As Range
Dim val As Range
Dim reqVal As Range
Dim Parameter As Range
With Worksheets("FT_CASE_xx")
For Each reqVal In .Range("D2", .Range("D" & Rows.Count).End(xlUp))
Set coeffsVal = reqVal.Offset(, -1)
Set val = reqVal.Offset(, -2)
Set Parameter = reqVal.Offset(, -3)
Dim xlFirstChar3 As String
xlFirstChar3 = Left$(Parameter, 1)
If ((xlFirstChar3 = "F") And (IsEmpty(reqVal.value) = False)) Then
If val.value = 0 Then
coeffsVal.value = reqVal.value
Else
coeffsVal.value = reqVal.value / val.value
End If
End If
Next reqVal
End With
Else
Exit Sub
End If
End If
End If
End Sub
Maybe a different management of target intersection? How?
My favoured method (which can also be useful in other situations) is to create a variable at global or module level (as required) then check this on each run of the code
Private disableEvents as Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
If disableEvents Then Exit Sub
disableEvents=True
<code here>
disableEvents=False
End sub
I am working on a document in which clickable cells place different values in column M on sheets 1 and 3. On sheet 1 when column M reads COMPLETE it will be cut from sheet 1 and pasted in sheet 2 when column M reads PARTIAL HOLD it will be cut from sheet 1 and pasted into sheet 3. I am having many problems with this but the problem I am asking for help on here is that in the following code the moves will work but i get a "run-time error '424' Object Required" and is not accepting Time as an object in my line of code Target.Offset(, 4).Value = Time but when I fix the issue in the code for the clickable cells the rows will no longer cut and paste.
This first code is the code that allows the rows to move but gets me an error
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDest As Range, rngDest2 As Range, rngDest3 As Range
If UCase(Target.Value) = "PARTIAL HOLD" Then
Set rngDest = Sheet3.Range("A5:Q5")
If Not Intersect(Target, Sheet1.Range("M5:M290")) Is Nothing Then
Application.EnableEvents = False
Target.EntireRow.Cut
rngDest.Insert Shift:=xlDown
Target.EntireRow.Delete
Application.EnableEvents = True
End If
ElseIf UCase(Target.Value) = "PROGRESSING" Then
Set rngDest3 = Sheet1.Range("A5:Q5")
If Not Intersect(Sheet3.Cells(Target.Row, Target.Column), Sheet3.Range("M5:M290")) Is Nothing Then
Application.EnableEvents = False
Target.EntireRow.Cut
rngDest3.Insert Shift:=xlDown
Target.EntireRow.Delete
Application.EnableEvents = True
End If
ElseIf UCase(Target.Value) = "COMPLETE" Then
Set rngDest2 = Sheet2.Range("A5:Q5")
If Not Intersect(Target, Sheet1.Range("M5:M290")) Is Nothing Then
Application.EnableEvents = False
Target.EntireRow.Cut
rngDest2.Insert Shift:=xlDown
Target.EntireRow.Delete
Application.EnableEvents = True
End If
End If
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column = 11 Then
Cancel = True
Target.Offset(, 2).Value = "IN PROGRESS"
Target.Offset(, 4).Value = Time
ElseIf Target.Column = 12 Then
Cancel = True
Target.Offset(, 1).Value = "COMPLETE"
Target.Offset(, 4).Value = Time
ElseIf Target.Column = 14 Then
Cancel = True
Target.Offset(, -1).Value = "PARTIAL HOLD"
End If
End Sub
The next code is the correction I have made to the clickable cells, but this stops the rows from cutting and pasting
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDest As Range, rngDest2 As Range, rngDest3 As Range
If UCase(Target.Value) = "PARTIAL HOLD" Then
Set rngDest = Sheet3.Range("A5:Q5")
If Not Intersect(Target, Sheet1.Range("M5:M290")) Is Nothing Then
Application.EnableEvents = False
Target.EntireRow.Cut
rngDest.Insert Shift:=xlDown
Target.EntireRow.Delete
Application.EnableEvents = True
End If
ElseIf UCase(Target.Value) = "PROGRESSING" Then
Set rngDest3 = Sheet1.Range("A5:Q5")
If Not Intersect(Sheet3.Cells(Target.Row, Target.Column),
Sheet3.Range("M5:M290")) Is Nothing Then
Application.EnableEvents = False
Target.EntireRow.Cut
rngDest3.Insert Shift:=xlDown
Target.EntireRow.Delete
Application.EnableEvents = True
End If
ElseIf UCase(Target.Value) = "COMPLETE" Then
Set rngDest2 = Sheet2.Range("A5:Q5")
If Not Intersect(Target, Sheet1.Range("M5:M290")) Is Nothing Then
Application.EnableEvents = False
Target.EntireRow.Cut
rngDest2.Insert Shift:=xlDown
Target.EntireRow.Delete
Application.EnableEvents = True
End If
End If
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.EnableEvents = False
On Error GoTo Xit:
If Target.Column = 11 Then
Cancel = True
Target.Offset(, 2).Value = "IN PROGRESS"
Target.Offset(, 4).Value = Time
ElseIf Target.Column = 12 Then
Cancel = True
Target.Offset(, 1).Value = "COMPLETE"
Target.Offset(, 4).Value = Time
ElseIf Target.Column = 14 Then
Cancel = True
Target.Offset(, -1).Value = "PARTIAL HOLD"
End If
Xit:
Application.EnableEvents = True
End Sub
What can I do to fix this?
I have a table in which I want to create a VBA code to write me the dates In ascending order in horizontally method but the problem when I activate the code, it gives me the date with the last criteria. my code is as follows:
Private Sub Worksheet_Activate()
Dim a As Range, ab As Range, b As Range, bc As Range
Set ab = Range("B3:E3")
Set bc = Range("A2:D2")
For Each a In ab
For Each b In bc
If Cells(3, 1) <> "" Then
Cells(3, a.Column) = Range("A3") + Cells(2, b.Column)
Else
Cells(3, a.Column) = ""
End If
Next
Next
End Sub
yes, I changed the Ranges identification names, but the most important part is the solution.
Private Sub Worksheet_Activate()
On Error Resume Next
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim cng As Range, rng As Range
Set rng = Range("B3:E3")
For Each cng In rng
If Cells(3, 1) <> "" Then
cng.Offset(0, 0).Value = cng.Offset(0, -1) + 1
ElseIf Cells(3, 1) = "" Then
cell.Offset(0, 5).Value = ""
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub