I have been successfully using a formula to populate an in-cell dropdown using Data Validation, List. The formula looks like this:
=IF(sel_ActionIndex=2, lstDraftRefs, IF(sel_ActionIndex=3, lstFinalRefs, 0))
Basically, a dynamic drop-down list appears in a cell based on a previous selection (Final or Draft).
I need to replicate this on another tab, so I made the list names local:
=IF(sel_ActionIndex=2, dbFTW!lstDraftRefs, IF(sel_ActionIndex=3, dbFTW!lstFinalRefs, 0))
Excel then gives me the error message, and I'm wondering how I can get this to work. I've not seen any documentation that local names cannot be used in a Data Validation formula. Any suggestions appreciated.
Try this:
Option Explicit
Option Base 1
' You can access the Lists from all Sheets of your Workbook!
Public lstDraftRefs As Validation
Public lstFinalRefs As Validation
Public Sub CreateValidation(ByVal SH As String, _
ByRef R As Range, ByRef C As Range, _
ByRef X As Validation, ByVal InputMessage As String)
Dim N As Long
Dim V As Variant
Dim I As Integer
Dim J As Integer
N = 0
For Each V In C
I = C.Row
J = C.Column
N = N + 1
Next
If (N <> 1) Then Exit Sub
ActiveSheet.Cells(I, J).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=" & SH & "!" & R.Address
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = InputMessage
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Set X = Selection.Validation
End Sub
Public Sub X()
Dim R As Range
Dim C As Range
ThisWorkbook.Worksheets(1).Activate
Set R = ThisWorkbook.ActiveSheet.Range("$A$2:$A$10")
ThisWorkbook.Worksheets(2).Activate
Set C = ThisWorkbook.ActiveSheet.Range("$A$1")
Call CreateValidation("Sheet1", R, C, lstDraftRefs, "Input lstDraftRefs")
ThisWorkbook.Worksheets(1).Activate
Set R = ThisWorkbook.ActiveSheet.Range("$B$2:$B$10")
ThisWorkbook.Worksheets(3).Activate
Set C = ThisWorkbook.ActiveSheet.Range("$A$1")
Call CreateValidation("Sheet1", R, C, lstFinalRefs, "Input lstFinalRefs")
End Sub
Have fun.
Do not change the "Set"s to "Let"s or "ByRef"s to "ByVal"s.
Related
I have total 15 columns with Data Validation Drop-down.
Drop-down for Column 2 to 15 are dependent on value selected in Column 1.
Drop-down for Column 3 is dependent on value selected in Column 2. If Column 3 value is selected directly then value for Column 2 must be populated in the excel cell of column 2.
Drop-down for Column 5 and 6 are dependent on Column 4 and so on.
Please find the code below for Column 2 and 3 dependent on Column 1 which is very lengthy. Is there any best/dynamic way to write this code to make sure all of my requirement is satisfied in VBA?
Dim rowNum As Long
Dim ListBoxRow As Long
Dim filterRowNum As Long
Dim col2 As String
Dim col3 As String
rowNum = 2
filterRowNum = 2
col2 = ""
col3 = ""
Do Until Worksheets("Col1Col2Col3Sheet").Cells(rowNum, 1).Value = ""
If InStr(1, Worksheets("Col1Col2Col3Sheet").Cells(rowNum, 1).Value, activeCellValue, vbTextCompare) Then
If filterRowNum = 2 Then
col2 = col2 & Worksheets("Col1Col2Col3Sheet").Cells(rowNum, 2).Value
col3 = col3 & Worksheets("Col1Col2Col3Sheet").Cells(rowNum, 5).Value
Else
If InStr(col2, Worksheets("Col1Col2Col3Sheet").Cells(rowNum, 2).Value) = 0 Then
col2 = col2 & "," & Worksheets("Col1Col2Col3Sheet").Cells(rowNum, 2).Value
End If
If InStr(col3, Worksheets("Col1Col2Col3Sheet").Cells(rowNum, 5).Value) = 0 Then
col3 = col3 & "," & Worksheets("Col1Col2Col3Sheet").Cells(rowNum, 5).Value
End If
End If
filterRowNum = filterRowNum + 1
End If
rowNum = rowNum + 1
Loop
With Worksheets("CustomSpreadsheet").Range("F" & ActiveCellRow).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=col2
.IgnoreBlank = True
.InCellDropdown = True
.ShowError = True
End With
With Worksheets("CustomSpreadsheet").Range("G" & ActiveCellRow).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=col3
.IgnoreBlank = True
.InCellDropdown = True
.ShowError = True
End With
Here's one way - abstract out all of the work to separate methods: one to give you a list of all unique matches, and the other to set up the validation:
'Set a cell validation list
'You might consider expanding this to also delete any previously-selected
' value if it's not in the list of values being added
Sub SetCellList(c As Range, lst As String)
With c.Validation
.Delete
If Len(lst) > 0 Then 'make sure there's something to add...
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=lst
.IgnoreBlank = True
.InCellDropdown = True
.ShowError = True
End If
End With
End Sub
'Return a comma-delimited list of all unique "sub-values"
'columnsToCheck: array of cell at the top(s) of the column(s) you want to scan for matches
'valuestoCheck: array of the value to look for in columnsToCheck
'returnColLetter: when a match is made, return all unique values from this column
Function Uniques(columnsToCheck, valuestoCheck, returnColLetter As String) As String
Dim arrA, arrB, rngCheck As Range, r As Long, i As Long, c As Range, n As Long, rng As Range
Dim dict As Object, bMatch As Boolean
Set dict = CreateObject("scripting.dictionary")
'translate array of column header cells to array of 2D arrays
'pick up values from return column
For i = LBound(columnsToCheck) To UBound(columnsToCheck)
Set c = columnsToCheck(i)
If i = LBound(columnsToCheck) Then
Set rng = c.Parent.Range(c, c.Parent.Cells(Rows.Count, c.Column).End(xlUp))
arrB = rng.EntireRow.Columns(returnColLetter).Value 'values to return
n = rng.Rows.Count '# of rows
Else
Set rng = c.Resize(n, 1) 'columns should be all the same size...
End If
columnsToCheck(i) = ToArray(rng)
Next i
'loop rowa to check and collect any matches
For r = 1 To n
bMatch = True
'loop columns to check
For i = LBound(columnsToCheck) To UBound(columnsToCheck)
If columnsToCheck(i)(r, 1) <> valuestoCheck(i) Then
bMatch = False
Exit For
End If
Next i
If bMatch Then dict(arrB(r, 1)) = True
Next r
Uniques = Join(dict.keys, ",")
End Function
'Safely get a 2D array from a range, even if the range is a single cell
Function ToArray(rng As Range)
Dim arr(1 To 1, 1 To 1)
If rng.Cells.Count = 1 Then
arr(1, 1) = rng.Value
ToArray = arr
Else
ToArray = rng.Value
End If
End Function
Example usage using a change event:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, c As Range, v
'this range depends only on the cell to the left
Set rng = Application.Intersect(Target, Me.Range("N2:N25"))
If Not rng Is Nothing Then
For Each c In rng.Cells
v = Trim(c.Value)
If Len(v) > 0 Then
'set list in next column over
SetCellList c.Offset(0, 1), _
Uniques(Array(lists.Cells(1, "A")), _
Array(v), "B")
End If
Next c
End If
'this range depends only on the two cells to the left
Set rng = Application.Intersect(Target, Me.Range("O2:O25"))
If Not rng Is Nothing Then
For Each c In rng.Cells
v = Trim(c.Value)
If Len(v) > 0 Then
'set list in next column over
SetCellList c.Offset(0, 1), _
Uniques(Array(lists.Cells(1, "A"), lists.Cells(1, "B")), _
Array(Trim(c.Offset(0, -1).Value), Trim(c.Value)), "C")
End If
Next c
End If
End Sub
I have a matrix with i.e dimensions 300x300 (x & y,size vary from project to project).
The names/numbers of the individual rows are transposed to the columns.
The matrix is divided diagonally, and I use it to tag relations between different "systems".
The tag have to be a unique number. See image:
I do not want duplicated relations, so I just want to use the white cells to add the tag.
(The black ones are there to show that the system cant have a relation with itself.)
I have tried to make a range, that I apply a Validation to later which shows me the next number in line for the tag:
Public MatrixRange as Range
Private Sub Worksheet_Activate()
Dim n As Integer
Dim NextRange As Range
Dim OldRange As Range
Dim LastRow As Long
With shMatrix
LastRow = .Range("A" & .Rows.Count).End(xlUp).row
Set MatrixRange = .Range("C11")
If LastRow <= 1 Then Exit Sub
For n = 2 To .Range(.Range("A9").Offset(1, 0).Address, "A" & LastRow).Rows.Count
Set OldRange = MatrixRange
Set NextRange = .Range(.Range("B9").Offset(n, 1), .Range("B9").Offset(n, -1 + n))
Set MatrixRange = Union(OldRange, NextRange)
Next n
End With
End Sub
This code give me the correct range that I want, but it sometimes hogs a whole lot of memory when I open the workbook or try to save. The RAM just goes up and up when I start it, before the workbook just crashes without any error message.
Rewriting the code to select the whole matrix, not just the one half, seems to fix the issue.
My question is this: is it possible to rewrite the code so I get the correct range, with a different method or are there any flaws in my code that will create a memory leak?
I call the above sub also when applying the Validation, if MatrixRange is not created:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ValMax As Integer
If MatrixRange Is Nothing Then
Call CreateMatrixRange
End If
ValMax = Application.WorksheetFunction.Max(MatrixRange)
With MatrixRange.Validation
.Delete
.Add Type:=xlValidateWholeNumber, AlertStyle:=xlValidAlertStop, _
Operator:=xlEqual, Formula1:=ValMax + 1
.IgnoreBlank = True
.InCellDropdown = False
.InputTitle = "Next number"
.ErrorTitle = "Error"
.InputMessage = ValMax + 1
.ErrorMessage = "Next number is: " & ValMax + 1
.ShowInput = True
.ShowError = True
End With
End Sub
Thank you for your answers!
Try the following:
Option Explicit
Private prMatrix As Range
'* plLastRow is used to check if the matrix range changes after it had been set
Private plLastRow As Long
Private Function GetMatrixRange() As Range
Dim lStartCol As Long: lStartCol = 3
Dim lStartRow As Long: lStartRow = 11
Dim lLastRow As Long
Dim i As Long
With shMatrix
lLastRow = .Cells(Rows.Count, "A").End(xlUp).Row
If lLastRow < lStartRow Then lLastRow = lStartRow
If prMatrix Is Nothing Or lLastRow <> plLastRow Then
plLastRow = lLastRow
Set prMatrix = .Cells(lStartRow, lStartCol)
'* Row Number -> Number of Columns mapping
'* Row 11 -> 1 column
'* Row 12 -> 2 columns
'* Row 13 -> 3 columns , ...etc
'* Therefore, Number Of Columns = Row Number - lStartRow + 1
For i = lStartRow + 1 To lLastRow
Set prMatrix = Union(prMatrix, .Cells(i, lStartCol).Resize(1, i - lStartRow + 1))
Next i
End If
End With
Set GetMatrixRange = prMatrix
End Function
Private Function GetNextValue() As Long
GetNextValue = WorksheetFunction.Max(GetMatrixRange) + 1
End Function
'Private Sub SetValidation()
' Dim lNextValue As Long
' lNextValue = GetNextValue
'
' With GetMatrixRange.Validation
' .Delete
' .Add Type:=xlValidateWholeNumber, _
' AlertStyle:=xlValidAlertStop, _
' Operator:=xlEqual, _
' Formula1:=lNextValue
' .IgnoreBlank = True
' .InCellDropdown = False
' .InputTitle = "Next number"
' .ErrorTitle = "Error"
' .InputMessage = lNextValue
' .ErrorMessage = "Next number is: " & lNextValue
' .ShowInput = True
' .ShowError = True
' End With
'End Sub
'
'Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' SetValidation
'End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error GoTo ErrorHandler
Application.EnableEvents = False
If Not Intersect(Target, GetMatrixRange) Is Nothing Then
If Target = Empty Then Target.Value = GetNextValue
Cancel = True
End If
ErrorHandler:
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ErrorHandler
Application.EnableEvents = False
Dim rWatched As Range: Set rWatched = Intersect(Target, GetMatrixRange)
Dim lNextValue As Long
Dim lEnteredValue As Long
If Not rWatched Is Nothing Then
Target.Select
If rWatched.Cells.Count > 1 Then
rWatched.ClearContents
MsgBox "You cannot change more than 1 matrix cell at a time"
ElseIf Not IsNumeric(rWatched.Value) Then
rWatched.ClearContents
MsgBox "Only numeric values allowed"
Else
If rWatched.Value <> Empty Then
lEnteredValue = rWatched.Value
rWatched.ClearContents
lNextValue = GetNextValue
If lEnteredValue <> lNextValue Then
If MsgBox("The next allowed value is: " & lNextValue & ". Do you want to accept it?", vbYesNo) = vbYes Then
rWatched.Value = lNextValue
End If
Else
rWatched.Value = lEnteredValue
End If
End If
End If
End If
ErrorHandler:
Application.EnableEvents = True
End Sub
I replaced the validation code with double-click and change event handlers. Feel free to remove these handlers and uncomment the validation and selection change code if you need to.
This code will do the following:
If you change any cell in the matrix, it will validate it and give
you the choice to accept the allowed value. Otherwise, it will delete
what you had entered.
If you double-click a cell in the matrix, it will be populated with the next value
Closed. This question needs details or clarity. It is not currently accepting answers.
Want to improve this question? Add details and clarify the problem by editing this post.
Closed 2 years ago.
Improve this question
I want to create multi dependent drop-down list( 3 dependent Dropdown ). I am able to create using data validation using formula =INDIRECT() But I am able to apply it for only one cell rather then I want to apply it for a range or for whole column. I want to use Macro(Vba code) to achieve this scenario.
Let say First drop-down contains Countries and second dependent dropdown contains States and third dependent dropdown contains Cities and the Cities dropdown should be multi select with "," seperation. I am able to achieve this using data list and formulas But i want to create it using VBA code. I want to give dropdown list in code itself and apply each dependent dropdown for range(column).
Click to view Screenshot 1
Click to view Screenshot 2
Click to view Screenshot 3
Click to view Screenshot 4
Try the next approach, please:
Copy the next code in a standard module. It will create (In cell "G1") the first Validation (States/Countries):
Sub CreateValidationTest()
Dim sh As Worksheet, rng As Range, strMerge As String, statesList As String
Dim lastColLet As String
Set sh = ActiveSheet 'use here your sheet to be processed
Set rng = sh.Range("G1") 'use here the range where you need to create the Validation
If Range("A1").MergeCells Then 'check if "A1" is part of a merged cells area
strMerge = Range("A1").MergeArea.Address
Else
MsgBox "No merge cells starting with ""A1""!": Exit Sub
End If
'create states list:_________________________________________________________________
lastColLet = Split(strMerge, "$")(3)
statesList = Join(Application.Index(Range("A2:" & lastColLet & 2).Value, 1, 0), ",")
'___________________________________________________________________________________
With rng.Validation 'create Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:=statesList
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With
End Sub
Copy the following event in the sheet module where the data to be processed exists (right click on the sheet name -> View code):
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range, oldVal As String, newVal As String
Dim arr As Variant, El As Variant
If Target.count > 1 Then GoTo exitHandler
If Target.Address(0, 0) = "G1" Then
'create the second validation
Dim stCell As Range, lastRow As Long, listValid As String
Set stCell = rows(2).Find(what:=Target.Value, LookIn:=xlValues, Lookat:=xlWhole)
If stCell Is Nothing Then Exit Sub
lastRow = cells(rows.count, stCell.Column).End(xlUp).row
'Debug.Print Range(stCell.Offset(1), cells(lastRow, stCell.Column)).Address: Stop
listValid = Join(Application.Transpose(Application.Index(Range(stCell.Offset(1), cells(lastRow, stCell.Column)).Value, 0, 1)), ",")
Application.EnableEvents = False
With Range("H1").Validation 'create the second Validation for Cities
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:=listValid
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With
Range("H1").Value = ""
ElseIf Target.Address(0, 0) = "H1" Then
Application.EnableEvents = False
newVal = Target.Value: Application.Undo
oldVal = Target.Value: Target.Value = newVal
If oldVal <> "" Then
If newVal <> "" Then
arr = Split(oldVal, ",")
For Each El In arr
If El = newVal Then
Target.Value = oldVal
GoTo exitHandler
End If
Next
Target.Value = oldVal & "," & newVal
Target.EntireColumn.AutoFit
End If
End If
End If
exitHandler:
Application.EnableEvents = True
End Sub
How to be used:
a. You firstly must run the CreateValidationTest Sub and then play with its validation list.
b. You must know that the first validation will be created in "G1" and the second one in "H1". The code will not allow to select an already existing item (in the string separated by comma).
Ok i want to make a searchable drop down list data validation without using helper column or combobox control...So how can i accomplish this..Everything is working fine but let say if i put at then click drop down arrow it will not calculate the worksheet change event..I want to run the worksheet change event every time value change in a certain cell..Suppose if i type at then worksheet change event should run 2 times..I mean every time i click in a keyboard alphabet then the worksheet change event need to run.How can i accomplish this...
Here is my code:
Worksheet Change Event:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim DestinationRng As Range, SourceRng As Range
Set SourceRng = Range("A1:A25")
Set DestinationRng = Range("C1:C25")
If Not Application.Intersect(DestinationRng, Range(Target.Address)) Is Nothing Then
'Target.Validation.Delete
If Target.Value = "" Then
DVDL SourceRng, Target, ""
Else
DVDL SourceRng, Target, Range(Target.Address).Value
End If
End If
End Sub
Here is worksheet selection change event
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim DestinationRng As Range, SourceRng As Range
Set SourceRng = Range("A1:A25")
Set DestinationRng = Range("C1:C25")
' 'If Target = ActiveCell Then Debug.Print yes
Debug.Print "Active:" & ActiveCell.Address
Debug.Print Target.Address
If Not Application.Intersect(DestinationRng, Range(Target.Address)) Is Nothing Then
If Target.Value = "" Then
DVDL SourceRng, Target, ""
Else
DVDL SourceRng, Target, Range(Target.Address).Value
End If
End If
End Sub
Here is the data validation sub procedure:
Public Sub DVDL(SourceRng As Range, PlaceRng As Range, SearchTxt As String)
Dim arr As Variant, arr2 As Variant
If SourceRng.Columns.Count > 1 Then
arr = Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Transpose(SourceRng.Value))
ElseIf SourceRng.Rows.Count > 1 Then
arr = Application.WorksheetFunction.Transpose(SourceRng.Value)
End If
arr = RemoveDuplicateS(arr)
If SearchTxt = "" Then
arr2 = arr
Else
arr2 = Filter(arr, SearchTxt, , vbTextCompare)
End If
For Each el In arr2
Debug.Print el
Next el
If LBound(arr2) <> UBound(arr) Then
'PlaceRng.Select
With PlaceRng.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=Join(arr2, ",")
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = False
End With
End If
End Sub
Here is the code for Removing duplicate value from source range:Not required if source contain unique value
Public Function RemoveDuplicateS(arr As Variant) As Variant
'From this function we return an array from an sorted array.
'It doesn't required extra space in memory because we use same array.
Dim i As Long, j As Long
If IsEmpty(arr) Then
RemoveDuplicateS = arr(0) 'If incoming array is empty then return empty one.
Else
j = LBound(arr)
For i = LBound(arr) To UBound(arr) - 1 'Run loop from first one to second last one.
If arr(i) <> arr(i + 1) Then 'if arr(5)<>arr(6) then put put the arr(5) value to the unique list.
arr(j) = arr(i)
j = j + 1 'Increase the j for indexing.
End If
Next i
arr(j) = arr(UBound(arr)) 'Put the last data to unique list.
ReDim Preserve arr(LBound(arr) To j) 'Delete the extra data from the array.
RemoveDuplicateS = arr 'Return the array.
End If
End Function
I want to put to Data validation for a column based on Headers of a named table.
Users will add more columns with country name as headers.
I have tried giving data validation the cell to named range, Named range value is =TripCost[#Headers] 'TripCost is the the name of the table.
But I am getting all the values. I want to ignore whichever value start with "Remark" or "Cost".
Is there a way to achieve this?
Try this code, please. It will create a validation for the active cell, using as many countries your named range will contain:
Private Sub selectiveNameValidation()
Dim sh As Worksheet, rng As Range, arrH As Variant, El As Variant, strList As String
Set sh = ActiveSheet
Set rng = ActiveCell 'use here what range you need
'arrH = Range("Headers").Value 'use here a named range for the headers in discussion ("Headers")
'or use your Table headers:
arrH = sh.ListObjects("TripCost").HeaderRowRange.Value' load the range in an array
For Each El In arrH
If Not (InStr(El, "Cost") > 0 Or InStr(El, "Remark") > 0) Then
strList = strList & IIf(strList = "", "", ",") & El 'build the list string
End If
Next
With rng.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=strList
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
End With
End Sub
If other strings to be excluded will appear, you must only extend the line
If Not (InStr(El, "Cost") > 0 Or InStr(El, "Remark") > 0) Then
with the new one:
If Not (InStr(El, "Cost") > 0 Or InStr(El, "Remark") > 0 Or InStr(El, "NewOne") > 0 ) Then
Try,
Sub test()
Dim Ws As Worksheet
Dim objList As ListObject
Dim vR(), vDB
Dim sFormula As String
Dim Target As Range
Dim j As Integer
Set Ws = ActiveSheet
Set objList = Ws.ListObjects("TripCost")
vDB = objList.HeaderRowRange
For j = 2 To UBound(vDB, 2) Step 2
n = n + 1
ReDim Preserve vR(1 To n)
vR(n) = vDB(1, j)
Next j
sFormula = Join(vR, ",")
Set Target = ActiveCell
With Target.Validation
.Delete
.Add xlValidateList, xlValidAlertStop, xlBetween, sFormula
End With
End Sub