I have a list of names in a row, A2 to AAS2, I also have a drop-down list containing all of those names. I would like some VBA code that when the list is changed excel jumps to the cell matching the item in the list. Could someone please help me with this? Thank you.
The names are just text, no named ranges.
Here is what I have tried so far:
Private Sub FindTicker()
Dim MyVariable As String
MyVariable = Range("L1").Value
Application.Goto Reference:=Range(MyVariable)
End Sub
And Also
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> [L1].Address Then
Exit Sub
Else
JumpToCell
End If
End Sub
Sub JumpToCell()
Dim xRg, yRg As Range
Dim strAddress As String
strAddress = ""
Set yRg = Range("A2:AAS2")
For Each xRg In yRg
'MsgBox Cell.Value
If xRg.Value = ActiveCell.Value Then
strAddress = xRg.Address
End If
Next
If strAddress = "" Then
MsgBox "The Day You Selected in Cell D4 Was Not Found On " & ActiveSheet.Name, _
vbInformation, "Ticker Finder"
Exit Sub
Else
Range(strAddress).Offset(0, 1).Select
End If
End Sub
When I tried using both of these when I changed the drop-down list nothing happened. No errors or anything.
Lots of ways to do this and with some tweaks your code above could work but its a bit inefficient and more complicated than it needs to be. The simplest way would be to use the Find method of the Range class to locate the cell:
Lets say your drop-down list of names is in cell A1 on sheet MySheet and the long list is in column C. Use the Find method to set a range variable to equal the first cell containing the item in cell A1.
Dim rng As Range
Dim ws As Worksheet
Set ws = Sheets("MySheet")
Set rng = ws.Range("C:C").Cells.Find(ws.Range("A1"), lookat:=xlWhole)
If Not rng Is Nothing Then ' the item was found
rng.Select
Else
MsgBox "This item is not in the list", vbInformation
End If
Related
I have a ByVal code to clear the contents of a specific range inside a table, it works. But I need to add a condition for the instructions execute if the RANGE VALUE (content) change, not if I only place the cursor on it.
Also, someone knows how to reference a table column in VBA? Now I'm using an estimated range "C1:C999" but I'll like to use his name "A_[OPERATION]".
This is the code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Application.Intersect(Range("C1:C999"), Range(Target.Address)) Is Nothing Then
Range(Selection, Selection.End(xlToRight)).ClearContents
End If
End Sub
You could use the change event instead.
Here's a link to the documentation:
https://learn.microsoft.com/en-us/office/vba/api/excel.worksheet.change
Alternatively, you could save the value of your target cell in a variable and check if the value changed before executing your clear contents.
For your second question, you should probably ask about it in a separate post.
A Worksheet Change
Adjust the table name (tName) and the header (column) name (hName).
I have adjusted it to clear contents in the cells after the column.
If you really need to clear the contents of the column too, then replace cel.Offset(, 1) with cel.
In a table, the current setup will automatically clear the contents of all the cells to the right of the specified column, if a value in the column is manually or via VBA changed. This will not work if the column contains formulas. Non-contiguous deletions are also supported.
The code
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const ProcName As String = "Worksheet_Change"
On Error GoTo clearError
Const tName As String = "A_"
Const hName As String = "OPERATION"
Dim rng As Range
Set rng = Range(tName & "[" & hName & "]")
Set rng = Intersect(rng, Target)
If rng Is Nothing Then GoTo ProcExit
Application.EnableEvents = False
With ListObjects(tName).HeaderRowRange
Dim LastColumn As Long
LastColumn = .Columns(.Columns.Count).Column
End With
Dim cel As Range
For Each rng In rng.Areas
For Each cel In rng.Cells
With cel.Offset(, 1)
.Resize(, LastColumn - .Column + 1).ClearContents
End With
Next cel
Next rng
CleanExit:
Application.EnableEvents = True
GoTo ProcExit
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0
GoTo CleanExit
ProcExit:
End Sub
A change in cell value is captured by the Worksheet_Change event-handle.
However, this handle will trigger even if it is a false change. For example, if the cell value before the change is "A", and user just entered "A" again in the cell, the Change event procedure will be triggered anyhow.
To avoid this, we can use Worksheet_Change and Worksheet_SelectionChange together.
Using Worksheet_SelectionChange, we record the old value somewhere, say a Name. Then using Worksheet_Change, we can compare what the user has entered against the Name to see if a true change is made.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Nm As Name: Set Nm = ActiveWorkbook.Names("OldValue")
If Target.Count = 1 Then
'This only record one old cell value.
'To record multiple cells old value, use a hidden Worksheet to do so instead of a Name.
Nm.Comment = Target.Value2
else
Nm.Comment = Target.Value2(1, 1)
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Nm As Name: Set Nm = ActiveWorkbook.Names("OldValue")
If Target.Value2 <> Nm.Comment Then
Debug.Print "True change"
Else
Debug.Print "False change"
End If
End Sub
You can access a table's methods and properties through the listobject object. Below is an example how to do so.
Sub Example()
Dim lo As ListObject
Dim lc As ListColumn
Set lo = Range("Table1").ListObject
Set lc = lo.ListColumns("Column2")
End Sub
That said, for your case, it would be Range("A_").ListObject.ListColumns("OPERATION").DataBodyRange.
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 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 am new in VBA and I want to write a program that when I manually select 1 or more items from a list the code searches with the name of the item and picks it from another sheet, copies the whole row and pastes it in a 3rd sheet. Is that possible? Preferably with a click of a button the selection is made. Thanks a lot!
Here is an example.
Sub FindAndMove()
Dim Finder As Range
Dim TheItem As Variant
With Sheets("Sheet1")
If Selection.CountLarge = 1 And Not Intersect(Selection, .Range("A2:A11")) Is Nothing Then
TheItem = Selection.Value
Else
MsgBox ("Please select an item from the list")
Exit Sub
End If
End With
With Sheets("Sheet2")
Set Finder = .Range("A:A").Find(TheItem, LookAt:=xlWhole)
If Finder Is Nothing Then
MsgBox ("Item not found!")
Exit Sub
End If
With Sheets("Sheet3")
Finder.EntireRow.Copy .Range("A" & .UsedRange.Rows.CountLarge + 1)
.Select 'Optional - show sheet 3
End With
End With
End Sub
Walking through the code:
When they click the button, if they only select 1 cell that's in our list.
Get the value of the item they selected
On Sheet2 - go find that value in column A
If you find it, copy the entire row to the end of Sheet3
You can modify the code by changing the sheet names in Sheet("Sheet1") to whatever you want.
You can also change the list range by changing .Range("A2:A11")
You can change the range to search by changing .Range("A:A")
Sheet 1:
Sheet 2:
Sheet 3: (after we select item 3 and click Find and Move)
Error Handling:
Edit:
Code to find multiple occurrences using FindNext
Sub FindAndMove()
Dim Finder As Range
Dim FirstAddress As Variant
Dim TheItem As Variant
With Sheets("Sheet1")
If Selection.CountLarge = 1 And Not Intersect(Selection, .Range("A2:A11")) Is Nothing Then
TheItem = Selection.Value
Else
MsgBox ("Please select an item from the list")
Exit Sub
End If
End With
With Sheets("Sheet2")
Set Finder = .Range("A:A").Find(TheItem, LookAt:=xlWhole)
If Finder Is Nothing Then
MsgBox ("Item not found!")
Exit Sub
End If
FirstAddress = Finder.Address
Do
With Sheets("Sheet3")
Finder.EntireRow.Copy .Range("A" & .UsedRange.Rows.CountLarge + 1)
End With
Set Finder = .Range("A:A").FindNext(Finder)
Loop While Not Finder Is Nothing And Finder.Address <> FirstAddress
End With
Sheets("Sheet3").Select 'Optional - Select Sheet3 After.
End Sub
I'm creating an excel file with column A to H are mandatory cells.
This excel file will be passing around for input.
So, I would like to highlight the empty cells as a reminder.
I have written the following code...
Sub Highlight_Cell()
Dim Rng As Range
For Each Rng In Range("A2:H20")
If Rng.Value = "" Then
Rng.Interior.ColorIndex = 6 ‘yellow
Else
Rng.Interior.ColorIndex = 0 'blank
End If
Next Rng
MsgBox "Please fill in all mandatory fields highlighted in yellow."
End Sub
However, I would like to set the range from A2 to the last row that contains data within column A to H.
Also, display the message box only when empty cell exist.
Could you please advise how should I amend?
Million Thanks!!!
This is a VBA solution that prevents the user from saving until the desired range is filled (acknowledging Gserg's comment that that the last row is one that has at least one cell entered)
In the second portion you can either add your sheet index directly, Set ws = Sheets(x) for position x, or Set ws = Sheets("YourSheet") for a specific sheet name
The code will only highlight truly blank cells within A to H of this sheet till the last entered cell (using SpecialCells as a shortcut). Any such cells will be selected by the code on exit
Put this code in the ThisWorkbook module (so it fires whenever the user tries to close the file)
Private Sub Workbook_BeforeClose(Cancel As Boolean)
bCheck = False
Call CheckCode
If bCheck Then Cancel = True
End Sub
Put this code in a standard module
Public bCheck As Boolean
Sub CheckCode()
Dim ws As Worksheet
Dim rng1 As Range
Dim rng2 As Range
bCheck = False
'works on sheet 1, change as needed
Set ws = Sheets(1)
Set rng1 = ws.Columns("A:H").Find("*", ws.[a1], xlValues, xlWhole, xlByRows)
If rng1 Is Nothing Then
MsgBox "No Cells in columns A:H on " & ws.Name & " file will now close", vbCritical
Exit Sub
End If
Set rng2 = ws.Range(ws.[a1], ws.Cells(rng1.Row, "H"))
On Error Resume Next
Set rng2 = rng2.SpecialCells(xlBlanks)
On Error GoTo 0
If rng2 Is Nothing Then Exit Sub
bCheck = True
rng2.Interior.Color = vbYellow
MsgBox "Please fill in all mandatory fields on " & ws.Name & " highlighted in yellow", vbCritical, "Save Cancelled!"
Application.Goto rng2.Cells(1)
End Sub