Can I use VBA function to return a (dynamic) list of acceptable values into Excel's data validation? - vba

For a given cell, I select Data/Validation and set Allow to "List". I now wish to set Source like so:
=rNames(REGS)
but that does not work (name not found). So I go Insert/Name/Define and create "REGNAMES" by simply assigning the formula above (no cell range). I then return to the Data/Validation and when I set Source like so:
=REGNAMES
Now I get "Source currently evaluates to error". Unfortunately, this error does not go away even after I ignore it. I can create a range formula in the sheet like so:
{=REGNAMES}
and drag this to the right across a couple cells and the rNames function faithfully returns
Option #1 | Options #2 | ...
That is, the function returns a range as intended.
I know that I can use macro code to manipulate the List setting for that cell out of VBA. I don't like these side-effects much. I would prefer a clean dependency tree built on functions. Any ideas how to get the Data/Validation to accept the array values returned from rNames?
Thanks.
PS: rNames returns the result range as a Variant, if that has any bearing.

I think the problem is that data validation dialog only accepts the following "lists":
an actual list of things entered directly into the Source field
a literal range reference (like $Q$42:$Q$50)
a named formula that itself resolves to a range reference
That last one is key - there is no way to have a VBA function just return an array that can be used for validation, even if you call it from a named formula.
You can write a VBA function that returns a range reference, though, and call that from a named formula. This can be useful as part of the following technique that approximates the ability to do what you actually want.
First, have an actual range somewhere that calls your arbitrary-array-returning VBA UDF. Say you had this function:
Public Function validationList(someArg, someOtherArg)
'Pretend this got calculated somehow based on the above args...
validationList = Array("a", "b", "c")
End Function
And you called it from $Q$42:$Q$50 as an array formula. You'd get three cells with "a", "b", and "c" in them, and the rest of the cells would have #N/A errors because the returned array was smaller than the range that called the UDF. So far so good.
Now, have another VBA UDF that returns just the "occupied" part of a range, ignoring the #N/A error cells:
Public Function extractSeq(rng As Range)
'On Error GoTo EH stuff omitted...
'Also omitting validation - is range only one row or column, etc.
Dim posLast As Long
For posLast = rng.Count To 1 Step -1
If Not IsError(rng(posLast)) Then
Exit For
End If
If rng(posLast) <> CVErr(xlErrNA) Then
Exit For
End If
Next posLast
If posLast < 1 Then
extractSeq = CVErr(xlErrRef)
Else
Set extractSeq = Range(rng(1), rng(posLast))
End If
End Function
You can then call this from a named formula like so:
=extractSeq($Q$42:$Q$50)
and the named formula will return a range reference that Excel will accept an allowable validation list. Clunky, but side-effect free!
Note the use of the keyword 'Set' in the above code. It's not clear from your question, but this might be the only part of this whole answer that matters to you. If you don't use 'Set' when trying to return a range reference, VBA will instead return the value of the range, which can't be used as a validation list.

I was just doing some research on accessing the contents of a Shapes dropdown control, and discovered another approach to solving this problem that you might find helpful.
Any range that can have a validation rule applied can have that rule applied programmatically. Thus, if you want to apply a rule to cell A1, you can do this:
ActiveSheet.Range("A1").Validation.Add xlValidateList, , , "use, this, list"
The above adds an in-cell dropdown validation that contains the items "use," "this," and "list." If you override the Worksheet_SelectionChange() event, and check for specific ranges within it, you can call any number of routines to create/delete validation rules. The beauty of this method is that the list referred to can be any list that can be created in VBA. I needed a dynamically-generated list of an ever-changing subset of the worksheets in a workbook, which I then concatenated together to create the validation list.
In the Worksheet_SelectionChange() event, I check for the range and then if it matches, fire the validation rule sub, thus:
Private Sub Worksheet_SelectionChange(ByVal Target as Range)
If Target.Address = "$A$1" Then
UpdateValidation
End If
End Sub
The validation list-builder code in UpdateValidation() does this:
Public Sub UpdateValidation()
Dim sList as String
Dim oSheet as Worksheet
For Each oSheet in Worksheets
sList = sList & oSheet.Name & ","
Next
sList = left(sList, len(sList) -1) ' Trim off the trailing comma
ActiveSheet.Range("A1").Validation.Delete
ActiveSheet.Range("A1").Validation.Add xlValidateList, , , sList
End Sub
And now, when the user clicks the dropdown arrow, he/she will be presented with the updated validation list.

Sounds like your rNames function is probably returning a 1-dimensional array (which will be treated as a row).
Try making your function return a column as a 1-based 2-dimensional array (Ansa(1,1) then Ansa(2,1) etc)

Couln't you rather use dynamic range names ? That's quite easy and does not require any vba.

For the future:
Following is then used in a named range and the named range set as the 'Data Validation' 'List' value
Function uniqueList(R_NonUnique As Range) As Variant
Dim R_TempList As Range
Dim V_Iterator As Variant
Dim C_UniqueItems As New Collection
On Error Resume Next
For Each V_Iterator In R_NonUnique
C_UniqueItems.Add "'" & V_Iterator.Parent.Name & "'!" & V_Iterator.Address, CStr(V_Iterator.Value2)
Next V_Iterator
On Error GoTo 0
For Each V_Iterator In C_UniqueItems
If R_TempList Is Nothing Then
Set R_TempList = Range(V_Iterator)
End If
Set R_TempList = Union(R_TempList, Range(V_Iterator))
Next V_Iterator
Set uniqueList = R_TempList
End Function

#user5149293 I higly appreciate your code, but I recommend to prevent the collection from throwing an error, when adding duplicate values. The usage of a custom formula in the data validation list or in Name-Manager-Formula prevents the code from using the vbe debugger, which makes it very hard to trace back errors here (I ran into this problem myself, when using your code).
I recommend to check the existence of key in the collection with a separate function:
Function uniqueList(R_NonUnique As Range) As Variant
'Returns unique list as Array
Dim R_TempList As Range
Dim V_Iterator As Variant
Dim C_UniqueItems As New Collection
For Each V_Iterator In R_NonUnique
'Check if key already exists in the Collection
If Not HasKey(C_UniqueItems, V_Iterator.Value2) Then
C_UniqueItems.Add Item:="'" & V_Iterator.Parent.Name & "'!" & V_Iterator.Address, Key:=CStr(V_Iterator.Value2)
End If
Next V_Iterator
For Each V_Iterator In C_UniqueItems
If R_TempList Is Nothing Then
Set R_TempList = Range(V_Iterator)
End If
Set R_TempList = Union(R_TempList, Range(V_Iterator))
Next V_Iterator
Set uniqueList = R_TempList
End Function
Function HasKey(coll As Collection, strKey As String) As Boolean
'https://stackoverflow.com/questions/38007844/generic-way-to-check-if-a-key-is-in-a-collection-in-excel-vba
Dim var As Variant
On Error Resume Next
var = coll(strKey)
HasKey = (Err.Number = 0)
Err.Clear
End Function

Related

Excel VBA .Find Function changing values in selection

Heya this is probably simple but I cannot figure out what is wrong.
I am trying to do .find for a specific date and change that selection to a user input date.
I have a userform to select a date from a combobox (date1_cbo). The combobox source is linked to dates on a worksheet (Backend). There is a textbox below for writing the new date to change it to (date1_txt). I keep getting an error
object variable or with block variable not set.
I have tried a few options without any luck here is my code:
Dim selection As Range
Dim check As Boolean
'input box validation
check = IsDate(date1_txt.Value)
If check = True Then
'find cell matching combobox
With Worksheets("Backend").Range("A1:A500")
Set selection = .Find(date1_cbo.Value) 'this is the problem
selection.Value = date1_txt.Value
End With
Else
End If
Interestingly .Find returns the range or Nothing. however because the combobox is linked to the cells I am searching through this should never return nothing... I dont understand why the error is occurring.
a variable named as 'selection' is bad coding practice but totally legal. Don't use such names for the sake of clarity.
Error 91 is caused when you are trying to read a property( .value) from null object. your selection variable is null cause date formats on the sheet and combobox are different.
Just convert to date before attempting to find it in sheet.
Set selection = .Find(CDate(date1_cbo.Value)) '/ once again, selection is valid but bad name for variable.
You are using a variable named Selection. VBA uses it as well. Rename your variable to anything else, rewrite your code and it should work. Even Selection1 is quite ok:
Public Sub TestMe()
Dim selection1 As Range
With Worksheets(1).Range("A1:A500")
Set selection1 = .Find("vi")
End With
If Not selection Is Nothing Then
selection1.Value = "some other value"
End If
End Sub
To change multiple values with Find() as here - A1:A10, then some possibility is to do it like this:
Public Sub TestMe()
Dim myRng As Range
With Worksheets(1).Range("A1:A500")
.Range("A1:A10") = "vi"
Set myRng = .Find("vi")
If Not myRng Is Nothing Then
Do Until myRng Is Nothing
myRng.Value = "New value"
Set myRng = .Find("vi")
Loop
End If
End With
End Sub
It is a bit slow, as far as it loops every time and it can be improved, if the range is united and replaced at once.

How to create a VBA formula that takes value and format from source cell

In Excel's VBA I want to create a formula which both takes the value from the source cell and the format.
Currently I have:
Function formEq(cellRefd As Range) As Variant
'thisBackCol = cellRefd.Interior.Color
'With Application.Caller
' .Interior.Color = thisBackCol
'End With
formEq = cellRefd.Value
End Function`
This returns the current value of the cell. The parts that I have commented out return a #VALUE error in the cell. When uncommented it seems the colour of the reference is saved however the Application.Caller returns a 2023 Error. Does this mean that this is not returning the required Range object?
If so how do I get the range object that refers to the cell that the function is used? [obviously in order to set the colour to the source value].
Here's one approach showing how you can still use ThisCell:
Function CopyFormat(rngFrom, rngTo)
rngTo.Interior.Color = rngFrom.Interior.Color
rngTo.Font.Color = rngFrom.Font.Color
End Function
Function formEq(cellRefd As Range) As Variant
cellRefd.Parent.Evaluate "CopyFormat(" & cellRefd.Address() & "," & _
Application.ThisCell.Address() & ")"
formEq = cellRefd.Value
End Function
This is the solution I found to the above question using Tim William's magic:
Function cq(thisCel As Range, srcCel As Range) As Variant
thisCel.Parent.Evaluate "colorEq(" & srcCel.Address(False, False) _
& "," & thisCel.Address(False, False) & ")"
cq = srcCel.Value
End Function
Sub colorEq(srcCell, destCell)
destCell.Interior.Color = srcCell.Interior.Color
End Sub
The destCell is just a cell reference to the cell in which the function is called.
The interior.color can be exchanged or added to with other formatting rules. Three extra points to note in this solution:
By keeping the value calculation in the formula this stops the possibility for circular referencing when it destCell refers to itself. If placed in the sub then it continually recalculates; and
If the format is only changed when the source value is changed, not the format as this is the only trigger for a UDF to run and thus change the format;
Application.Caller or Application.ThisCell cannot be integrated as when it refers to itself and returns a value for itself it triggers an infinite loop or "circular reference" error. If incorporated with an Address to create a string then this works though as per Tim William's answer.

Searching and Returning bold values in VBA

I know that this probably isn't the most ideal way to to do this but just bear with me.
I have a document with a few tables on it. I'm using a userform to search the tables/sub-categories and return the relevant values. I want to select the sub categories with a range of option buttons on a userform, these will in turn set the range for the search function to look within. I also want to dynamically update the option buttons if a new table was to be added or anything along those lines.
The only thing that differentiates the title of a sub-category/table, and the items within it, is that the title of a sub-category/table is bold. So what I'm looking to do is search the first column of the spreadsheet and return the names of any entries in bold. These values are then used to set the names of the option buttons :).
The following function is my attempt at finding the text entities in column a that are in bold, returning them and setting each to an individual variable to be used in another function. The bold1 .... variables are all globally defined variables as I need them in another sub, as is the page variable which contains the relevant page to be used. Currently the code returns an error stating "variable or with block not set" and using the debugger I can see that bold1 .... and all the other boldx variables have no value set. Does anybody know whats going on/how to fix this function.
Thanks in advance :)
Sub SelectBold()
Dim Bcell As Range
For Each Bcell In Worksheets(Page).Range("A1:A500")
If Bcell.Font.Bold = True Then
Set bold1 = Bcell
End If
Next
End Sub
EDIT: I simplified the above function, to remove clutter and help narrow in on the issue. I want the above function to store the contents of the found cell (any cell in the document in bold at this stage) in the variable bold1
This will return an array of values from bold cells in column A of Page.
You can fill a combo or list box with theses values using their list property.
ComboBox1.List = getSubCategories("Sheet1")
Function getSubCategories(Page As String) As String()
Dim arrSubCategories() As String
Dim count As Long
Dim c As Range
With Worksheets(Page)
For Each c In .Range("A2", .Range("A" & Rows.count).End(xlUp))
If c.Font.Bold Then
ReDim Preserve arrSubCategories(count)
arrSubCategories(count) = c.Value
count = count + 1
End If
Next
End With
getSubCategories = arrSubCategories
End Function
you may find useful to have a Range returned with subcategories cells found:
Function SelectBold(Page As String, colIndex As String) As Range
With Worksheets(Page)
With .Range(colIndex & "1", .Cells(.Rows.Count, colIndex).End(xlUp)).Offset(, .UsedRange.Columns.Count)
.FormulaR1C1 = "=if(isbold(RC[-1]),"""",1)"
.Value = .Value
If WorksheetFunction.CountA(.Cells) < .Rows.Count Then Set SelectBold = Intersect(.SpecialCells(xlCellTypeBlanks).EntireRow, .Parent.Columns(1))
.Clear
End With
End With
End Function
Function IsBold(rCell As Range)
IsBold = rCell.Font.Bold
End Function
to be possibly exploited as follows:
Option Explicit
Sub main()
Dim subCategoriesRng As Range, cell As Range
Set subCategoriesRng = SelectBold(Worksheets("bolds").Name, "A") '<--| pass worksheet name and column to search in
If Not subCategoriesRng Is Nothing Then
For Each cell In subCategoriesRng '<--| loop through subcategories cells
'... code
Next cell
End If
End Sub

Count visible blank cells using VBA?

When I enter the following function as a UDF in a cell:
Function VisibleBlankCells(r As Range) As Long
On Error Resume Next
VisibleBlankCells = Intersect(r.SpecialCells(xlCellTypeVisible), r.SpecialCells(xlCellTypeBlanks)).Count
On Error GoTo 0
End Function
r.SpecialCells(xlCellTypeBlanks) evaluates ALL cells in r as empty regardless of whether they contain text or not. What might be the cause of this and an alternative solution?
Get rid of the On Error Resume Next for a start - you should always assume that your code will fail and account for it accordingly, simply ignoring errors will just complicate matters.
Secondly ,there is no need to use Intersect - just identify the visible cells directly, and then use a further SpecialCells() method to identify the blank child cells.
Function VisibleBlankCells(r As Range) As Long
VisibleBlankCells = r.SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeBlanks).Count
End Function
tested with this:
Sub test_code()
Dim r As Range: Set r = Selection
Debug.Print CountBlanks(r)
End Sub
Function CountBlanks(r As Range) As Long
CountBlanks = r.SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeBlanks).Count
End Function
This kind of filter mechanism won't work in an UDF (see this for information on that). I suggest a looping inside your UDF:
Public Function VisibleBlankCells(rng As Range) As Long
Dim i As Integer
Dim cell As Range
i = 0
For Each cell In rng
If cell.Rows.Hidden = False And _
cell.Columns.Hidden = False And _
cell.Value = "" Then
i = i + 1
End If
Next
VisibleBlankCells = i
End Function
However, there may be some problems regarding the updating and functionality:
The value of the UDF only updates after editing the referenced range or calling other UDFs. So if you hide a column or row in that range, it won't have an instant effect
In the (working) execution of your code in a Sub, the visible cells (also) refer to yet unused cells in your worksheet to be "not visible". In my solution however, all cells that are not contained in a hidden row/column are considered visible.

Method Back Reference to calling Worksheet/Cell

I have a method to execute a Distinct Result from a Table Column on a Worksheet.
The result of the Method will go into a Data-Validation listbox in a cell. I have two needs right now that require me to "dummy mitigate" the method's use, by limiting the number of columns passed to the method by one. This part i can get done, what i would like to do is have it so that if there are multiple columns in the Range, then it "pukes" on the user, stating that an illegal function call was made from "Worksheet"."Cell" and to alert the IT Support to resolve the problem.
Getting the Worksheet is great and the easy part. Its more of getting the reference to the Calling Cell without explicitely forcing the IT Support to pass the Cell as a value to the method.
Any ideas on how to extract the Calling Cell?
Ultimately this method will be used across several worksheets to perform the same logic with different ranges being passed to it.
Edited 2012-09-24 10:30am CST
Here is my implementation so far, havent utilized the Application.Caller method into it.
Function UniqueValues(ws As Worksheet, col As String) As Variant
Dim rng As Range: Set rng = ws.Range(col)
Dim dict As New Scripting.Dictionary
If Not (rng Is Nothing) Then
Dim cell As Range, val As String
For Each cell In rng.Cells
val = CStr(cell.Value)
If Not dict.Exists(val) Then
dict.Add val, val
End If
Next cell
End If
'Return value
UniqueValues = dict.Items
End Function
This method is already being used in code-behind logic. I will be copying this logic and making it apart of the Application.Volatile segment for the Excel Workbook i am working on. Will be similar but not the same.
Here is the current design, not much but what i am workgin with atm.
Function DistinctValues(rng As Range)
Application.Volatile True
If rng.Columns.Count > 1 Then
Err.Raise -1542376, rng.Worksheet.name, "An invalid function call was made!"
End If
End Function
Application.Caller returns the cell that called a function. See this MSDN definition.