I am trying to use selection from cell E73 to hide or display rows on two different tabs. my vba code below only works for one tab and not both. Can you spot where my issue is? Any help is appreciated.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
If Target.CountLarge > 1 Then Exit Sub
Select Case Target.Address(0, 0)
Case "E73"
Set rng1 = Sheets("Proposal").Rows("349:403")
Set rng2 = Sheets("Binder").Rows("350:404")
Case "E128"
Set rng1 = Sheets("Proposal").Rows("404:462")
Set rng2 = Sheets("Binder").Rows("405:463")
End Select
If rng Is Nothing Then Exit Sub
Select Case Target.Value
Case "Included"
rng1.Hidden = False
rng2.Hidden = False
Case "Excluded"
rng1.Hidden = True
rng2.Hidden = True
End Select
End Sub
If rng Is Nothing Then Exit Sub
This is always True, because rng is never Set.
A guess as to what you want:
Select Case Target.Address(0, 0)
Case "E73"
Set rng1 = Sheets("Proposal").Rows("349:403")
Set rng2 = Sheets("Binder").Rows("350:404")
Case "E128"
Set rng1 = Sheets("Proposal").Rows("404:462")
Set rng2 = Sheets("Binder").Rows("405:463")
Case Else
Exit Sub
End Select
Select Case Target.Value
Case "Included"
rng1.Hidden = False
rng2.Hidden = False
Case "Excluded"
rng1.Hidden = True
rng2.Hidden = True
End Select
End Sub
Related
By using Concatenate to combine 6 entries and then evaluate them, my worksheet changes the value of cell AA1 to be greater than 1 when a duplicate entry of any other row has been made. The Excel formula works well, but I need help on the VBA side: The code below is part of a Private Sub Worksheet_Change(ByVal Target As Range) with many operations that continue to work perfectly, while this does nothing at all. I already have Conditional Formatting highlighting the duplicate row entries, but I need a msg box to tell users what they have done wrong and how to fix it.
Dim fng As Range
Set fng = Range("$AA$1")
If Not Intersect(Target, fng) Is Nothing Then
If Target.Value > 1 Then
MsgBox "You already entered this barrel -- Enter another barrel over the duplicate. If no more barrels, change Grade to X, amounts to 0, and Producer to Z ZZ", vbOKOnly, "OOPS!"
End If
End If
In case it makes more sense to see the entire code, he it is:
Private Sub Worksheet_Change(ByVal Target As Range)
Target.Worksheet.Unprotect Password:="Cami8"
Dim rng As Range
Set rng = Range("F3:F10001")
If Not Intersect(Target, rng) Is Nothing Then
Target.Offset(0, 4) = Now
ActiveWorkbook.Save
End If
Application.EnableEvents = True
Dim ung As Range
Set ung = Range("J3:J10005")
If Not Intersect(Target, ung) Is Nothing Then
Target.Offset(-1, -3).Locked = True
End If
Application.EnableEvents = True
Dim wng As Range
Set wng = Range("J3:J10005")
If Not Intersect(Target, wng) Is Nothing Then
Target.Offset(-1, -4).Locked = True
End If
Application.EnableEvents = True
Dim xng As Range
Set xng = Range("J3:J10005")
If Not Intersect(Target, xng) Is Nothing Then
Target.Offset(-1, -5).Locked = True
End If
Application.EnableEvents = True
Dim kng As Range
Set kng = Range("J3:J10005")
If Not Intersect(Target, kng) Is Nothing Then
Target.Offset(-1, -6).Locked = True
End If
Application.EnableEvents = True
Dim qng As Range
Set qng = Range("J3:J10005")
If Not Intersect(Target, qng) Is Nothing Then
Target.Offset(-1, -7).Locked = True
End If
Application.EnableEvents = True
Dim cng As Range
Set cng = Range("C3:E10001")
If Not Intersect(Target, cng) Is Nothing Then
Application.EnableEvents = False
Target.Value = UCase(Target.Value)
Target.NumberFormat = "General"
Application.EnableEvents = True
End If
Dim sng As Range
Set sng = Range("E3:E10002")
If Not Intersect(Target, sng) Is Nothing Then
If Len(Target) > 1 Then
MsgBox "You entered GRADE with a letter and a space -- Click on the cell and enter only a letter", vbOKOnly, "OOPS!"
End If
End If
Dim fng As Range
Set fng = Range("$AA$1")
If Not Intersect(Target, fng) Is Nothing Then
If Target.Value > 1 Then
MsgBox "You already entered this barrel -- Enter another barrel over the duplicate. If no more barrels, change Grade to X, amounts to 0, and Producer to Z ZZ", vbOKOnly, "OOPS!"
End If
End If
Target.Worksheet.Protect Password:="Cami8"
End Sub
Thanks for the great tip about Worksheet_Calculate, since that did the trick! I just removed the code I had in Worksheet_Change and input this:
Private Sub Worksheet_Calculate()
Const lVal As Long = 2
Dim rCell As Range
Set rCell = Range("AA1")
If rCell.Value = lVal Then
MsgBox "You already entered this barrel -- Enter another barrel over the duplicate. If no more barrels, change Grade to X, amounts to 0, and Producer to Z ZZ", vbOKOnly, "OOPS!"
End If
End Sub
To protect a second section of dynamic data when rows are removed in the first section, I need to change the last section of existing code below to a dynamic range that begins at E3 and ends either at the first row where column E is blank, last row where it is => zero or use a dynamic cell reference (N2) that shows # of last row (or anything that will work). At present, I handle this new need by manually changing E10001 to the new end of the first section of data (i.e, E5006). All of my attempts (used every option I could find) at this dynamic code resulted in the date being inserted 3 columns to right of any entry I make in my test spreadsheet. Thanks in advance for any help.
Private Sub Worksheet_Change(ByVal Target As Range)
Target.Worksheet.Unprotect Password:="Midnight"
On Error Resume Next
Application.EnableEvents = True
Dim hng As Range
Set hng = Range("F3:F10001")
If Intersect(Target, hng) Is Nothing Then
Target.Offset(-1, -4).Locked = True
End If
Application.EnableEvents = True
Dim xng As Range
Set xng = Range("F3:F10001")
If Intersect(Target, xng) Is Nothing Then
Target.Offset(-1, -3).Locked = True
End If
Application.EnableEvents = True
Dim wng As Range
Set wng = Range("F3:F10001")
If Intersect(Target, wng) Is Nothing Then
Target.Offset(-1, -2).Locked = True
End If
Application.EnableEvents = True
Dim qng As Range
Set qng = Range("F3:F10001")
If Intersect(Target, qng) Is Nothing Then
Target.Offset(-1, -1).Locked = True
End If
Application.EnableEvents = True
Dim sng As Range
Set sng = Range("F3:F10001")
If Intersect(Target, sng) Is Nothing Then
Target.Offset(-1, 0).Locked = True
End If
Dim cng As Range
Set cng = Range("B3:C10001")
If Not Intersect(Target, cng) Is Nothing Then
Application.EnableEvents = False
Target.Value = UCase(Target.Value)
Application.EnableEvents = True
End If
Dim rng As Range
Set rng = Range("E3:E10001")
If Not Intersect(Target, rng) Is Nothing Then
Target.Offset(0, 3) = Now
End If
Target.Worksheet.Protect Password:="Midnight"
End Sub
I am concluding that this is not possible. I have created a workaround using reference to calculated values in another sheet to fill the cells not needed with null data.
I need a sheet in Excel to activate if any cells in a column are selected as "Yes", but my VBA code won't stick - simple enough to do for one cell, but the whole column is throwing me. The cells are a drop down list with solely the options "Yes" or "No"
Currently trying:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$H$11:$H$23" Then
If ActiveWorkbook.Worksheets("Sheet1").Range("H11:H23").Value = "Yes" Then
Sheets("Sheet2").Visible = True
Else
Sheets("Sheet2").Visible = False
End If
End If
End Sub
Any tips? Thanks
An easier solution without looping would be to count the Yes using WorksheetFunction.CountIf method.
Use the following to show Sheet2 if at least one cell has the Yes.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim TestRange As Range
Set TestRange = Me.Range("H11:H23")
If Not Application.Intersect(Target, TestRange) Is Nothing Then 'if target is in test range
If Application.WorksheetFunction.CountIf(TestRange, "Yes") > 0 Then
Worksheets("Sheet2").Visible = True
Else
Worksheets("Sheet2").Visible = False
End If
End If
End Sub
If all cells in the test range need to be Yes then change it to
If Application.WorksheetFunction.CountIf(TestRange, "Yes") = TestRange.Cells.Count Then
i think you could try:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range, rng As Range
Dim Inrng As Boolean
If Not Intersect(Target, Me.Range("H11:H23")) Is Nothing Then
'Set a boolean variable to false
Inrng = False
'Set a range to loop
Set rng = Me.Range("H11:H23")
'Start looping the range
For Each cell In rng
'Convert the value of a cell to Upper case to avoid case sensitive issues
If UCase(cell.Value) = "YES" Then
'Turn the variable to true if value appears in the range
Inrng = True
'Exit the loop to avoid time consuming
Exit For
End If
Next cell
If Inrng = True Then
Worksheets("Sheet2").Visible = True
Else
Worksheets("Sheet2").Visible = False
End If
End If
End Sub
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
I am trying to run this worksheet change event for two different columns(A) and (I)...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Inte
r.Offset(0, 1).Value = Date
Next r
Application.EnableEvents = True
End Sub
This event is something i found on this forum. Its purpose is to make it so whenever data is ever entered into column "a" it auto inputs the date into the cell directly right of it. I want this to happen twice on the worksheet. I can't figure out how to change/add to it. I am trying to get it to run the logic for column A and I on my spreadsheet.
Just expand the range you set to the A variable.
Set A = Range("A:A, I:I")
Rewritten as,
Private Sub Worksheet_Change(ByVal Target As Range)
if not intersect(range("A:A, I:I"), target) is nothing then
'add error control
on error goto safe_exit
'don't do anything until you know something has to be done
dim r as range
Application.EnableEvents = False
For Each r In intersect(range("A:A, I:I"), target)
r.Offset(0, 1).Value = Date 'do you want Date or Now?
Next r
end if
safe_exit:
Application.EnableEvents = True
End Sub
edited after OP's comment
expanding on #Jeeped solution, you can avoid looping:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Set rng = Intersect(Range("A:A, I:I"), Target) ' define range of interest
If Not rng Is Nothing Then ' check it's not "nothing"
If WorksheetFunction.CountA(rng) = rng.Count Then 'check for all of its cells being not empty
On Error GoTo safe_exit 'add error control
Application.EnableEvents = False 'don't do anything until you know something has to be done
rng.Offset(, 1).Value = Date 'write Date next to all relevant changed cells
End If
End If
safe_exit:
Application.EnableEvents = True
End Sub