I am following up on an answer that has been posted before at the following link: Circular Reference with drop-down list
The answer works when the dropdown lists and sources are on the same cell on their respective sheets, but I am trying to find out how this work if the lists and source are not on the same cell. Thank you
I am following this answer:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Address = "$B$5" And Sh.Name <> "Sheet3" Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
Dim w As Long
For w = 1 To Worksheets.Count
With Worksheets(w)
'skip this worksheet and Sheet3
If CBool(UBound(Filter(Array(Sh.Name, "Sheet3"), _
.Name, False, vbTextCompare))) Then
.Range("B5") = Target.Value
'.Range("B5").Interior.ColorIndex = 3 '<~~testing purposes
End If
End With
Next w
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
I am trying to have two lists where I can change one and it'll update the other. How do I create the same result in the dropdown for example on cell A3 on Sheet1 and D9 on Sheet2?
Here is what I am after: I want to generate on two sheets (sheet 1, sheet 2) a drop-down list that says either "Complete" or "Incomplete." If I change sheet 1 from Complete to Incomplete, I want sheet 2 to say the same thing, but I also want vice versa
(If I change sheet 2 from Complete to Incomplete, I want sheet 1 to change).
Try like this:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim arrCells, el, i As Long, m, tgt, arr
arrCells = Array("Sheet1|D3", "Sheet2|B4") 'all cells with the list
tgt = Sh.Name & "|" & Target.Address(False, False)
m = Application.Match(tgt, arrCells, 0) 'matches one of the list cells?
If Not IsError(m) Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
For i = LBound(arrCells) To UBound(arrCells)
If arrCells(i) <> tgt Then 'skip the cell raising the event...
arr = Split(arrCells(i), "|")
ThisWorkbook.Sheets(arr(0)).Range(arr(1)).Value = Target.Value
End If
Next i
Application.EnableEvents = False
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
Related
I am trying to use VBA so that I can input a value in cell B7 in sheet2 and then it would automatically populate in C7 in sheet3 and also work vice versa. I tried the code below and couldn't get it to work, any suggestions? Also would the code be the same for a string of a number?
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo eh
If Not Intersect(Target, ThisWorkbook.Sheets("sheet 2").Range("B7")) Is Nothing Then
Application.EnableEvents = False
ThisWorkbook.Sheets("sheet 3").Range("C" & Target.Row - 0).Value = Target.Value
eh:
Application.EnableEvents = True
If Err <> 0 Then MsgBox Err & " " & Err.Description, , "Error in Worksheet_Change event, sheet 2"
End If
End Sub
A Workbook SheetChange: Same Value in Cells of Worksheets
Note that the code needs to be copied to the ThisWorkbook module.
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim wsNames As Variant: wsNames = VBA.Array("sheet 2", "sheet 3")
Dim CellAddresses As Variant: CellAddresses = VBA.Array("B7", "C7")
Dim iCell As Range
Dim n As Long
For n = 0 To UBound(wsNames)
If StrComp(Sh.Name, wsNames(n), vbTextCompare) = 0 Then
Set iCell = Intersect(Sh.Range(CellAddresses(n)), Target)
If Not iCell Is Nothing Then
Application.EnableEvents = False
Me.Worksheets(wsNames(1 - n Mod 2)) _
.Range(CellAddresses(1 - n Mod 2)).Value = iCell.Value
Application.EnableEvents = True
End If
Exit For
End If
Next n
End Sub
Im using VBA code to create multiple selection drop down list. The code will make each drop down list in target cell become multuple selection list with function:
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then GoTo Exitsub
The source of drop down list in target cell is =indirect(b14), and b14 is another drop down list (single selection). Now if b14's value will become list1, Id like to make my target's cell list become multiple selection list. In any other case I want it work in normal excel way. I've tried to precache the list source with if Evaluate(Target.Validation.Formula1) = "=list1" then
but I get mismatch error for Evaluate(Target.Validation.Formula1).
How can I do it?
EDIT:
There are some example screenshots from my worksheet, not to misunderstand it's construction.
A1:A5 named range list1, B1:B5 named range list2, B14 data validation list =list1
D14 data validation list with =INDIRECT(B14) formula
First of all, using the Worksheet_Change event means that every worksheet change is going to run your code, so Target could be any range not just B14. The assumption that you can use the Target.Validation.Formula1 property on any cell is wrong because cells that do not have validation will not have this property available.
Secondly, you are doing this:
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then GoTo Exitsub
I believe that you are making the assumption that this is referring to cells within the Target range but it really refers to all the cells with validation within the entire sheet. Try this code to clarify that:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngValidation As Range
Set rngValidation = Target.SpecialCells(xlCellTypeAllValidation)
Debug.Print Target.Address
If Not rngValidation Is Nothing Then Debug.Print rngValidation.Address
End Sub
You can see in your Immediate window that no matter what cell you are editing the rngValidation will always point to all the validation cells within the worksheet.
Thirdly, you are doing this:
If Evaluate(Target.Validation.Formula1) = "=list1"
which won't work because Evaluate("=Indirect(B14)") simply returns an array and not a String as you are assuming.
Finally, if I read the question I understand that you want the list in cell D14 to be changed based on value in B14 but you keep referring to the Target as D14. If B14 is changed then B14 is the Target, not D14. D14 can only be the Target if you change D14. That's just how the Event works.
Since I am not clear on what you want, I am assuming two scenarios:
Cell B14 is changed and you want to update D14
Cell D14 is selected and you want the list to be updated before you click the dropdown
Scenario 1 - Cell B14 is changed and you want to update D14 (or other cells)
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim rngValidation As Range
Dim rngValidTarget As Range
Dim rngCell As Range
Dim rngArea As Range
Set rngValidation = Target.Worksheet.Cells.SpecialCells(xlCellTypeAllValidation)
Set rngValidTarget = Intersect(Target, rngValidation)
If rngValidTarget Is Nothing Then GoTo ExitSub
'validTarget could still be a multi-cell range
On Error Resume Next
For Each rngArea In rngValidTarget.Areas
For Each rngCell In rngArea
If rngCell.Validation.Type = xlValidateList Then
If rngCell.Validation.Formula1 = "=List1" Then
Debug.Print rngCell.Address & " - Validation: " & rngCell.Validation.Formula1
'Do whatever logic you need to update other cells linking to this one
'
'
'
End If
End If
Next rngCell
Next rngArea
On Error GoTo 0
ExitSub:
Application.EnableEvents = True
End Sub
Scenario 2 - Cell D14 (or equivalent) is selected and you want the list to be updated before you click the dropdown
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
Dim rngValidation As Range
Dim rngValidTarget As Range
Dim rngCell As Range
Dim rngArea As Range
Dim rngList As Range
Dim listFound As Boolean
Set rngValidation = Target.Worksheet.Cells.SpecialCells(xlCellTypeAllValidation)
Set rngValidTarget = Intersect(Target, rngValidation)
If rngValidTarget Is Nothing Then GoTo ExitSub
'validTarget could still be a multi-cell range
On Error Resume Next
For Each rngArea In rngValidTarget.Areas
For Each rngCell In rngArea
If rngCell.Validation.Type = xlValidateList Then
Set rngList = Nothing
Set rngList = Evaluate(rngCell.Validation.Formula1)
listFound = False
If Not rngList Is Nothing Then
listFound = (rngList.Name.Name = "List1")
End If
If listFound Then
Debug.Print rngCell.Address & " - list found"
'Do whatever logic you need to update rngCell
'
'
Else
Debug.Print rngCell.Address & " - list not found"
'Do whatever logic you need to update rngCell
'
'
End If
End If
Next rngCell
Next rngArea
On Error GoTo 0
ExitSub:
Application.EnableEvents = True
End Sub
EDIT 1
You can use the following code to translate formulas:
Private Function TranslateFormulaToUS(ByVal formulaText As String) As String
On Error Resume Next
With GetBlankEditableCell
.Formula2Local = formulaText
TranslateFormulaToUS = .Formula
.Formula = vbNullString
End With
On Error GoTo 0
End Function
Private Function GetBlankEditableCell() As Range
Dim wSheet As Worksheet
Static blankCell As Range
'
'Re-use, if still blank
If Not blankCell Is Nothing Then
If IsEmpty(blankCell.Value2) Then
Set GetBlankEditableCell = blankCell
Exit Function
End If
End If
'
'Find a Blank cell
For Each wSheet In ThisWorkbook.Worksheets
Set blankCell = GetEditableBlankCellFromSheet(wSheet)
If Not blankCell Is Nothing Then Exit For
Next wSheet
Set GetBlankEditableCell = blankCell
End Function
Private Function GetEditableBlankCellFromSheet(wSheet As Worksheet) As Range
Dim rngBlanks As Range
Dim rngCell As Range
'
On Error Resume Next
Set rngBlanks = wSheet.UsedRange.SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If rngBlanks Is Nothing Then Set rngBlanks = wSheet.Cells(1, 1)
'
'Check if Worksheet is Macro Protected
If (wSheet.ProtectContents Or wSheet.ProtectDrawingObjects _
Or wSheet.ProtectScenarios) And Not wSheet.ProtectionMode _
Then
For Each rngCell In rngBlanks
If Not rngCell.Locked Is Nothing Then
Set GetEditableBlankCellFromSheet = rngCell
Exit Function
End If
Next rngCell
Else
Set GetEditableBlankCellFromSheet = rngBlanks.Cells(1, 1)
End If
End Function
And now you can replace something like:
Set rngList = Evaluate(rngCell.Validation.Formula1)
with:
Set rngList = Evaluate(TranslateFormulaToUS(rngCell.Validation.Formula1))
EDIT 2
If you would like to avoid the translation mentioned in EDIT 1 then you could use a dynamic relative named range as mentioned in the comments.
Let's start with the current layout (I presume I got it right):
Named range List1 is a local scope range:
Named range List2 is also a local scope range:
The B column (rows could vary from sheet to sheet) has data validation set to List1:
Let's create a third named range called RemoteDV:
Select first cell in column D that has the validation
Create a LOCAL named range and add the formula =INDIRECT(Sheet1!$B8) (or whatever row you are on - i.e. first row in both B and D column that has validation - I have 8 here). NOTE! Do not use an absolute address (i.e. locking the row with =INDIRECT(Sheet1!$B$8)) because we want the named range to work for the entire D column
Now, let's link the new named range to validation:
Select all cells in column D that have validation
Link to the named range you have just created
The end result is that you do not have to translate the formula anymore.
You also do not need Evaluate anymore:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.EnableEvents = False
Dim rngValidation As Range
Dim rngValidTarget As Range
Dim rngCell As Range
Dim rngArea As Range
Dim rngList As Range
Dim listFound As Boolean
Dim formulaText As String
Dim nameList As Name
Set rngValidation = Target.Worksheet.Cells.SpecialCells(xlCellTypeAllValidation)
Set rngValidTarget = Intersect(Target, rngValidation)
If rngValidTarget Is Nothing Then GoTo ExitSub
'validTarget could still be a multi-cell range
On Error Resume Next
For Each rngArea In rngValidTarget.Areas
For Each rngCell In rngArea
If rngCell.Validation.Type = xlValidateList Then
Set rngList = Nothing
formulaText = rngCell.Validation.Formula1
If Left$(formulaText, 1) = "=" Then
formulaText = Right$(formulaText, Len(formulaText) - 1)
End If
Set nameList = Nothing
Set nameList = rngCell.Worksheet.Names(formulaText)
Set rngList = nameList.RefersToRange
listFound = False
If Not rngList Is Nothing Then
listFound = (rngList.Name.Name = "'" & rngList.Worksheet.Name & "'!" & "List1") _
Or (rngList.Name.Name = rngList.Worksheet.Name & "!" & "List1")
End If
If listFound Then
Debug.Print rngCell.Address & " - list found"
'Do whatever logic you need to update rngCell
'
'
Else
Debug.Print rngCell.Address & " - list not found"
'Do whatever logic you need to update rngCell
'
'
End If
End If
Next rngCell
Next rngArea
On Error GoTo 0
ExitSub:
Application.EnableEvents = True
End Sub
EDIT:
Below is a simple block of code that should do what you need. First, I created a data validation drop down in cell A1. Next, I created a list named List1 and pointed it to a range of values. Next, I set the List -> Formula of the data validation to be =INDIRECT(B14). And finally I entered the text List1 in cell B14.
I ran the below test script to see what my output was.
Sub Test()
Dim rangeWithDropdown As Range
Set rangeWithDropdown = Sheets("Sheet1").Range("A1")
Debug.Print rangeWithDropdown.Validation.Formula1
Debug.Print Evaluate(rangeWithDropdown.Validation.Formula1).Name
Debug.Print Evaluate(rangeWithDropdown.Validation.Formula1).Name = ThisWorkbook.Names("List1").Value
End Sub
My output was the following:
=INDIRECT(B14)
=Sheet1!$D$1:$D$4
True
When requesting the formula alone, it returns =INDIRECT(B14). When evaluating the formula, and returning the name, it returns the range that I established. And finally, when testing for equality against the named range, it returns true.
Is my understanding correct? Can you try running this code against your workbook (update the data validation cell reference), and then tell me which line throws an error?
END EDIT
The reason that your code isn't working is that Evaluate(=indirect(B14)) does not return the name of the range, but rather the address of the range. So, if List1 refers to Range("A1:A10"), then the Evaluate function will return Sheet1!Range("A1:A10"). When you try comparing a string ("list1") to a range, you get the type mismatch error.
One option is to compare the range returned against the expected range of "List1". For example, the following code might work:
If evaluate(activecell.validation.formula1).name = activeworkbook.Names("List1").Value
I see there has been a lot of work by others. I didn't want to "steal" their solutions so i didn't read them completely. I hope my contribution won't be out of place. I humbly proceed to post my answer.
If in the column with the first drop-down lists (column B) the said drop-down list are already present, then our "List1" outcome will be a possible value. This solution checks if such value is "List1" and creates the second drop-down list accodingly:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Declarations.
Dim DblStartingRow As Double
Dim DblEndingRow As Double
Dim RngFirstDropDownList As Range
Dim RngSecondDropDownList As Range
Dim RngRange01
Dim StrTrigger As String
''''''''''''''''''''''''''''
'VARIABLES SETTINGS - Start'
''''''''''''''''''''''''''''
'StrTrigger will be the value that if found in the first drop down _
list will trigger the creation of the second drop down list.
StrTrigger = "List1"
'DblStartingRow is the first row that will possibly contain one of _
our drop down list.
DblStartingRow = 14
'DblStartingRow is the last row that will possibly contain one of _
our drop down list.
DblEndingRow = Rows.Count
'Setting RngFirstDropDownList and RngSecondDropDownList to match _
the entire columns where our lists of drop-down lists will be found.
Set RngFirstDropDownList = Range("B:B")
Set RngSecondDropDownList = Range("D:D")
''''''''''''''''''''''''''
'VARIABLES SETTINGS - End'
''''''''''''''''''''''''''
'Resetting RngSecondDropDownList to cover only the rows we need to _
cover according to DblStartingRow and DblEndingRow
Set RngSecondDropDownList = RngSecondDropDownList.Resize(DblEndingRow - DblStartingRow + 1, 1).Offset(DblStartingRow - 1, 0)
'Checking if Target intersects with RngSecondDropDownList. If there _
is no intersection, the subroutine is terminated. Otherwise RngRange01 _
is set as such intersection.
On Error Resume Next
Set RngRange01 = Intersect(Target, RngSecondDropDownList)
On Error GoTo 0
If RngRange01 Is Nothing Then Exit Sub
'Covering each cell in RngRange01
For Each RngSecondDropDownList In RngRange01
'Setting RngFirstDropDownList as the cell in the column of first _
drop-down lists at the same row of our (possible) second drop-down _
list.
Set RngFirstDropDownList = Cells(RngSecondDropDownList.Row, RngFirstDropDownList.Column)
'Focusing RngSecondDropDownList.
With RngSecondDropDownList.Validation
'Removing validation.
.Delete
'Checking if RngFirstDropDownList contains StrTrigger.
If RngFirstDropDownList.Formula = StrTrigger Then
'Adding the dropdown list.
.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:="=INDIRECT(" & RngFirstDropDownList.Address & ")"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End If
End With
Next
End Sub
To be put in the sheets' module, it will activate everytime the selection is changed. If the selection intersect with the range with the second drop-down list, it will insert such drop-down list for each cell in said intersection. Works for single and multiple cell selection. I've set every possible parameter i could think of as a variable that can be changed in the first part of the subroutine after declarations. This should do what the question was asking.
Then again, if the question wanted the second drop-down list to be created only when:
there is a first drop-down list in the proper cell and
said first drop-down list had a specific Validation.Formula1
then the code i'd suggest is this one:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Declarations.
Dim DblStartingRow As Double
Dim DblEndingRow As Double
Dim RngFirstDropDownList As Range
Dim RngSecondDropDownList As Range
Dim RngRange01
Dim StrTrigger As String
Dim StrValidation As String
''''''''''''''''''''''''''''
'VARIABLES SETTINGS - Start'
''''''''''''''''''''''''''''
'StrTrigger will be the formula that if found in Validation.Formula1 _
of the first drop-down list will trigger the creation of the second _
drop down list.
StrTrigger = "=List1"
'DblStartingRow is the first row that will possibly contain one of _
our drop down list.
DblStartingRow = 14
'DblStartingRow is the last row that will possibly contain one of _
our drop down list.
DblEndingRow = Rows.Count
'Setting RngFirstDropDownList and RngSecondDropDownList to match _
the entire columns where our lists of drop-down lists will be found.
Set RngFirstDropDownList = Range("B:B")
Set RngSecondDropDownList = Range("D:D")
''''''''''''''''''''''''''
'VARIABLES SETTINGS - End'
''''''''''''''''''''''''''
'Resetting RngSecondDropDownList to cover only the rows we need to _
cover according to DblStartingRow and DblEndingRow
Set RngSecondDropDownList = RngSecondDropDownList.Resize(DblEndingRow - DblStartingRow + 1, 1).Offset(DblStartingRow - 1, 0)
'Checking if Target intersects with RngSecondDropDownList. If there _
is no intersection, the subroutine is terminated. Otherwise RngRange01 _
is set as such intersection.
On Error Resume Next
Set RngRange01 = Intersect(Target, RngSecondDropDownList)
On Error GoTo 0
If RngRange01 Is Nothing Then Exit Sub
'Covering each cell in RngRange01
For Each RngSecondDropDownList In RngRange01
'Setting RngFirstDropDownList as the cell in the column of first _
drop-down lists at the same row of our (possible) second drop-down _
list.
Set RngFirstDropDownList = Cells(RngSecondDropDownList.Row, RngFirstDropDownList.Column)
'Focusing RngSecondDropDownList.
With RngSecondDropDownList.Validation
'Removing validation.
.Delete
'Checking if RngFirstDropDownList contains a drop-down list _
based on StrTrigger.
On Error GoTo CP_No_Drop_down_List
If RngFirstDropDownList.Validation.Formula1 = StrTrigger Then
'Adding the dropdown list.
.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, _
Formula1:="=INDIRECT(" & RngFirstDropDownList.Address & ")"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End If
CP_No_Drop_down_List:
On Error GoTo 0
End With
Next
End Sub
This code is similar to the previous one but it will in fact check if there is a first drop-down list based on the Validation.Formula1 specified. Note that if you want the second drop-down list be created acconding to StrTrigger and not to the actual indirect reference of the first drop-down list value, you can substitute the line
Formula1:="=INDIRECT(" & RngFirstDropDownList.Address & ")"
with the line
Formula1:=StrTrigger
I have a spreadsheet containing a list of all possible project tasks for different types of project in a range, and a column in the range which states to which project it relates.
In cell A1 I have a dropdown box of different project types - containing the values "Custom API" and "Custom File".
The data range is C3:E10, and example data is shown in the Example Data.
Column A: Task name
Column B: Task Duration
Column C: Task Owner
Column D: Project Type
What I'd like from some vba code is:
On selecting "Custom API" from the dropdown in A1, all the tasks in the range with the Project type "All" and "Custom API" to be shown, and all "Custom File" project task rows to be hidden.
On selecting "Custom File" from the dropdown in A1, all the tasks in the range with the Project type "All" and "Custom File" to be shown, and all "Custom API" project task rows to be hidden.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" and Target.Cells.Count = 1 Then
Application.ScreenUpdating = False
Range("B4:E10").EntireRow.Hidden = False
Dim taskList as Range
Set taskList = Range(Range("E4"),Range("E4").End(xlDown))
Dim taskCheck as Range
For each taskCheck in taskList
taskCheck.EntireRow.Hidden = taskCheck <> Target
Next
End If
End Sub
You are really just setting up an AutoFilter without header dropdowns.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
Range("B4:E10").EntireRow.Hidden = False
If AutoFilterMode Then AutoFilterMode = False
With Range(Cells(3, "E"), Cells(4, "E").End(xlDown))
.AutoFilter field:=1, Criteria1:=Array(Cells(1, "A").Value, "All"), _
Operator:=xlFilterValues, VisibleDropDown:=False
End With
End If
End Sub
You can clear the AutoFilter and show all values by adding an asterisk (e.g. *) to your list of values for the A1 dropdown.
Please try this code. Make sure that the spelling of the items in A1 match with that in the test column.
Private Sub Worksheet_Change(ByVal Target As Range)
' 03 Jan 2019
' set these two constants to match your sheet
Const FirstDataRow As Long = 4
Const TestClm As String = "E"
Dim Rng As Range
Dim Arr As Variant
Dim Tgt As String
Dim C As Long
Dim R As Long
' (If the address is $A$1 it can't have more than one cell)
If Target.Address = "$A$1" Then
Tgt = Target.Value
Rows.Hidden = False
C = Columns(TestClm).Column
Set Rng = Range(Cells(FirstDataRow, C), Cells(Rows.Count, C).End(xlUp))
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
With Rng
Arr = .Value
For R = 1 To UBound(Arr)
Rows(R + FirstDataRow - 1).Hidden = Not (CBool(StrComp(Arr(R, 1), Tgt, vbTextCompare) = 0) Or _
CBool(StrComp(Arr(R, 1), "All", vbTextCompare) = 0))
Next R
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End Sub
I have a master sheet (Sheet 1) that contains 50+ rows of specific items. I have a sheet corresponding to each item and named as such (ie. item 1 = "Clearing" so sheet 2 is named "Clearing"). I have a drop down menu for each item in Column D that displays "Yes" or "No".
I currently have a basic code that hides Sheets based on if my "Column D" drop down menus for 50+ rows = "No" (ie. Item 1 marked as "No" so sheet 2 is hidden).
Private Sub Worksheet_Change(ByVal Target As Range)
If [D2] = "Yes" Then
Sheets("Clearing").Visible = True
Else
Sheets("Clearing").Visible = False
End If
If [D3] = "Yes" Then
Sheets("Grubbing").Visible = True
Else
Sheets("Grubbing").Visible = False
End If
End Sub
I want to be able to run this in a loop for all 50+ items by using a range of cells D2:D50+ without having to enter in each sheet name as I've done above. I haven't been able to figure out how to manage this by looking at other's examples.
Any help is much appreciated.
Using the Worksheet_Change event you started out with:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Set rng = Range(Range("D2"), Range("D2").End(xlDown))
If Not Intersect(Target, rng) Is Nothing Then
If Target.Count = 1 Then
On Error GoTo ErrorHandler
If Target = "Yes" Then
Sheets(Target.Offset(, -1).Value).Visible = True
Else
Sheets(Target.Offset(, -1).Value).Visible = False
End If
End If
End If
Exit Sub
ErrorHandler:
MsgBox "The sheet '" & Target.Offset(, -1) & "' does not exist!"
End Sub
If your data is set up with the sheet name next to column D (or anywhere really, just adjust the script), you can just loop through.
Sub hide_Sheets()
Dim mainWS As Worksheet
Dim rng As Range
Set mainWS = ThisWorkbook.Sheets("Sheet1")
Set rng = mainWS.Range("C2:C5") ' Change range as needed
Dim cel As Range
For Each cel In rng
If cel.Offset(0, 1).Value = "Yes" Then
ThisWorkbook.Sheets(cel.Value).Visible = True
Else
ThisWorkbook.Sheets(cel.Value).Visible = False
End If
Next cel
End Sub
I'm trying to hide all rows in a worksheet if a reference cell has no text in it. I'm using the following formula
Option Explicit
Private Sub Worksheet_Activate()
Dim r As Range, c As Range
Set r = Range("d4:f1000")
Application.ScreenUpdating = False
For Each c In r
If Len(c.Text) = 0 Then
c.EntireRow.Hidden = True
Else
c.EntireRow.Hidden = False
End If
Next c
Application.ScreenUpdating = True
End Sub
When I run it it runs indefinitely, and I have to exit the program in Task Manager. I think this is happening because I haven't initially defined c. Am I correct about this?
Thank you for taking the time to respond!
first off you can shortened and speed up your code like follows:
Option Explicit
Private Sub Worksheet_Activate1()
Dim r As Range, c As Range
Set r = Range("d4:f1000")
Application.ScreenUpdating = False
For Each c In r
c.EntireRow.Hidden = Len(c.Text) = 0
Next c
Application.ScreenUpdating = True
End Sub
but if you're after hiding all rows where range D4:F100 cells in the same row are blank, then you can use this code:
Private Sub Worksheet_Activate4()
Application.ScreenUpdating = False
With Range("D4:F1000") '<-- reference your range
With .Columns(1).SpecialCells(xlCellTypeBlanks) '<--| reference its 1st column blank cells
With .Offset(, 1).SpecialCells(xlCellTypeBlanks) '<--| reference referenced blank cells whose side cell is blank
With .Offset(, 1).SpecialCells(xlCellTypeBlanks) '<--| reference referenced blank cells whose side cell is blank
.EntireRow.Hidden = True '<--| hide rows when all three cells are blank
End With
End With
End With
End With
Application.ScreenUpdating = True
End Sub
which can be made much less verbose like follows:
Private Sub Worksheet_Activate5()
Application.ScreenUpdating = False
Range("D4:F1000") _
.Columns(1).SpecialCells(xlCellTypeBlanks) _
.Offset(, 1).SpecialCells(xlCellTypeBlanks) _
.Offset(, 1).SpecialCells(xlCellTypeBlanks) _
.EntireRow.Hidden = True '<--| hide rows when all three cells are blank
Application.ScreenUpdating = True
End Sub
with the only caveat that should no rows match that criteria it'd return an error
should this be an issue then just add On Error Resume Next at the top of the sub