Wrong value is returned when calling a function from a cell - vba

First post yall.
Long story short, in Excel, when I call the following function (it's in its own module) from a cell, it returns the wrong value. The function returns the correct value when calling it from a sub, as well as when I step through the code (to the end), but the moment I call it from Excel, it returns a different value. Background at the bottom.
Things I've Tried
Making it a Public Function
Giving it an argument
Changing the function and/or module name
Moving it out of a module
Restarting Excel
A bunch of random stuff
It really is just this specific function that's giving me this issue, simpler functions do what they're told. I have to assume it has something to do with the order of events Excel is doing things, or the limits of what parts of Excel a function can change.
Function ActiveDisciplineFilters()
Application.Volatile 'makes the function update automatically
Dim disccolumn As Range
Dim uniquedisc() As String
Dim uniquediscstring As String
'create a string of unique values from the Discipline column
i = 0
If Range("LayerList[Discipline]").SpecialCells(xlCellTypeVisible).Address = Range("LayerList[Discipline]").Address Then
ActiveDisciplineFilters = "None"
Exit Function
End If
For Each cell In Range("LayerList[Discipline]").SpecialCells(xlCellTypeVisible)
If InStr(1, uniquediscstring, cell.Value) = 0 Then
If i <> 0 Then
uniquediscstring = uniquediscstring & ", " & cell.Value
Else
uniquediscstring = cell.Value
i = 1
End If
End If
Next
ActiveDisciplineFilters = uniquediscstring
End Function
Background
In Excel, I have a table. I'm taking all the data in one specific column of that table and creating a string of the unique values in that range (separated by comma). That string must be placed in another cell, for reasons I don't need to get into. If a filter is applied to the column, the unique values update automatically.
What would make Excel give me the right answer when I call it from a sub, then the wrong one when I call it from a cell?

Unfortunately, none of the SpecialCells methods work in a UDF. If you need this to be run from the worksheet as a formula, then your code should look like this instead:
Function ActiveDisciplineFilters()
Application.Volatile 'makes the function update automatically
Dim disccolumn As Range
Dim uniquedisc() As String
Dim uniquediscstring As String
Dim i As Long
Dim cell As Range
Dim bHidden As Boolean
'create a string of unique values from the Discipline column
i = 0
For Each cell In Range("LayerList[Discipline]").Cells
If cell.EntireRow.Hidden = False Then
If InStr(1, uniquediscstring, cell.Value) = 0 Then
If i <> 0 Then
uniquediscstring = uniquediscstring & ", " & cell.Value
Else
uniquediscstring = cell.Value
i = 1
End If
End If
Else
bHidden = True
End If
Next
If Not bHidden Then uniquediscstring = "None"
ActiveDisciplineFilters = uniquediscstring
End Function

Related

VBA code to only show rows that contain similar text to an input field?

I'm new to VBA and am trying to cobble together some code to allow a user to input a word (or several words) into a cell and then show a list of matching row entries.
I have tried the following code but am getting an "instring = type mismatch" error.
Note that "B3" is the field dedicated for the "search word" and column F is the column containing the text I want to search within. If the word is contained, I want to show that row and hide all rows that don't contain that word.
Sub Find_Possible_Task()
ROW_NUMBER = 0
SEARCH_STRING = Sheets("codeset").Range("B3")
ROW_NUMBER = ROW_NUMBER + 1
ITEM_IN_REVIEW = Sheets("codeset").Range("F:F")
If InStr(ITEM_IN_REVIEW, SEARCH_STRING) Then
Do
Cells(c.Row).EntireRow.Hidden = False
Loop Until ITEM_IN_REVIEW = ""
End If
End Sub
TIA!
Few bad coding conventions or even possibly downright errors:
It's a good practice to explicity declare the scope Public/Private of your Sub procedure
Unless you're passing the variables from some place else, they need to be declared with Dim keyword
Using Option Explicit will help you prevent aforementioned error(s)
(Subjective) variables in all caps are ugly and in most programming languages it is convention to reserve all caps variables names for constants (Const)
Option Explicit
Private Sub keep_matches()
Dim what As Range
Dim where As Range
Dim res As Range ' result
Dim lr As Long ' last active row
Dim ws As Worksheet: Set ws = Sheets("codeset")
lr = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
Set what = ws.Range("B3")
Set where = ws.Range("F1:F" & lr)
' we'll create an extra column for a loop in our .Find method
where.Copy
ws.Range("F1").EntireColumn.Insert
ws.Range("F1").PasteSpecial xlPasteValues
where.EntireRow.Hidden = True ' preemptively hide them all
Set where = ws.Range("F1:F" & lr)
Set res = where.Find(what, lookIn:=xlValues) ' ilook for matches, 1st attempt
If Not res Is Nothing Then ' if found
Do Until res Is Nothing ' repeat for all results
res.EntireRow.Hidden = False
res = "Checked"
Set res = where.FindNext(res)
Loop
Else
MsgBox("No matches were found")
where.EntireRow.Hidden = False ' we don't wanna hide anything
End If
ws.Range("F1").EntireColumn.Delete ' remove the extra help column for Find method
End Sub
Should work as expected.
If there are any question, let me know.
instead of instr(), consider range.find().
Sub Find_Possible_Task()
Dim SEARCH_STRING As String
Dim ITEM_IN_REVIEW As Range
Dim found As Range
Dim i As Integer
SEARCH_STRING = Sheets("Sheet1").Range("B3").Value
i = 1
Do
Set ITEM_IN_REVIEW = Sheets("Sheet1").Cells(i, 6)
Set found = ITEM_IN_REVIEW.Find(What:=SEARCH_STRING)
If found Is Nothing Then
ITEM_IN_REVIEW.EntireRow.Hidden = True
End If
i = i + 1
Loop Until ITEM_IN_REVIEW = ""
End Sub
alternatively, consider using filter table:
1. check if your table has filter on ==> if yes, pass. if no, turn on filter.
2. filter column F for keyword to contain value in cell B3.

How to set a different link in each cell in a range?

I'm programming a Macro in VB for Excel 2013 that search for coincidences in different worksheets, and add a link to the cells that match.
I'm havin torubles to insert the link in the cell, since the link must be different for a range of cells, I need help here.
Here is my code
Dim bufferDetails As String
Dim tmpCell As String
Dim spot As String
Dim cell As Variant
Dim cellSpots As Variant
For Each cell In Worksheets("MMS-Locations").Range("D2:D1833")
If (cell.Value2 = "NULL") Then
cell.Value2 = "NULL"
Else
tmpCell = cell.Text
'A62
If (Left(tmpCell, 3) = "A62") Then
spot = spotName(tmpCell)
For Each cellSpots In Worksheets("DetailedMap").Range("G60:CF123")
If (cellSpots.Value2 = spot) Then
For Each linkToSpot In Worksheets("MMS-Locations").Range("H2:H1833")
Worksheets("MMS-Locations").Hyperlinks.Add _
Anchor:=Range(linkToSpot), _
Address:="http://example.microsoft.com", _
ScreenTip:="Microsoft Web Site", _
TextToDisplay:="Microsoft"
Next linkToSpot
Debug.Print ("Encontrado " + cellSpots)
End If
Next cellSpots
End If
End If
Next cell
End Sub
Function spotName(fullName As String) As String
Dim realSpot As String
Dim lenght As Integer
lenght = Len(fullName) - 3
realSpot = Right(fullName, lenght)
spotName = realSpot
End Function
As I was thinking the linkToSpot variable contains the actual cell in the range, so I can move my selection of the sell, but my code fails in there with this error:
Error in the Range method of the '_Global' object,
Just for reference, here is what I use to convert a phone number to an email for texting..setting it as a hyperlink in the current cell.
ActiveCell.Value = myNumbr
Set myRange = ActiveCell
ActiveSheet.Hyperlinks.Add anchor:=myRange, Address:="mailto:" & myRange.Value, TextToDisplay:=myRange.Value`
Keep your code simple to start with, until you find a working script, then add other items. Make good use of the F8 key to step through your code to find out exactly where an error occurs.

A way to verify specific filter contents

I have a spreadsheet that uses a filter on a few columns of data. One of these columns has 10 different possible values. I want to verify that there is a specific filter in place--that is, not just that autofiltermode = true--but to actually check what the value of that filter is. Is there a way to do this in vba?
For example, if I might want to make sure that the user is only looking at customers, 1 of the 10 values in my field. So I'm hoping I can say something like if filtervalue = "customers" then.
Additionally, I don't want to verify cell data, I'm asking if there's a way to verify a filter.
The sample code below will check for the criteria selections given the first cell of the range containing the filter, and the index of the column to check.
Option Explicit
Sub Test()
'first argument is first cell of headers being filtered
'second argument is column to check for filter criteria
Debug.Print GetCriteria(Sheet1.Range("A1"), 3)
End Sub
Function GetCriteria(rng As Range, lngFilterIndex As Long) As String
Dim strCriteria As String
Dim objFilter As AutoFilter
Dim lngCriteriaCount As Long
Dim lngCounter As Long
Set objFilter = rng.Parent.AutoFilter
' no autofilter
If objFilter Is Nothing Then
GetCriteria = ""
Exit Function
End If
' autofilter but no selection
If Not objFilter.Filters(lngFilterIndex).On Then
GetCriteria = ""
Exit Function
End If
' iterate criteria
strCriteria = ""
lngCriteriaCount = objFilter.Filters(lngFilterIndex).Count
If lngCriteriaCount = 1 Then
strCriteria = objFilter.Filters(lngFilterIndex).Criteria1
Else
For lngCounter = 1 To objFilter.Filters(lngFilterIndex).Count
strCriteria = strCriteria & objFilter.Filters(lngFilterIndex).Criteria1(lngCounter)
Next lngCounter
End If
GetCriteria = strCriteria
End Function

Why does autofit row VBA code in Excel keep causing #value error in my formula?

I have a concatenate based on offset array code that I'm using to combine data.
Public Function concatPlusIfs(rng As Range, sep As String, lgCritOffset1 As Long, lgCritOffset2 As Long, varCrit1 As Variant, lgCritOffset3 As Long, lgCritOffset4 As Long, varCrit2 As Variant, Optional noDup As Boolean = False, Optional skipEmpty As Boolean = False) As String
Dim CL As Range, strTemp As String
If noDup Then 'remove duplicates, use collection to avoid them
Dim newRow As New Collection
On Error Resume Next
For Each CL In rng.Cells
If skipEmpty = False Or Len(Trim(CL.Text)) > 0 Then
If CL.Offset(lgCritOffset1, lgCritOffset2) = varCrit1 And CL.Offset(lgCritOffset3, lgCritOffset4) = varCrit2 Then newRow.Add CL.Text, CL.Text
End If
Next
For i = 0 To newRow.Count
strTemp = strTemp & newRow(i) & sep
Next
Else
For Each CL In rng.Cells
If skipEmpty = False Or Len(Trim(CL.Text)) > 0 Then
If CL.Offset(lgCritOffset1, lgCritOffset2) = varCrit1 And CL.Offset(lgCritOffset3, lgCritOffset4) = varCrit2 Then strTemp = strTemp & CL.Text & sep
End If
Next
End If
concatPlusIfs = Left(strTemp, Len(strTemp) - Len(sep))
End Function
The code works great. It's not mine, but I tweaked someone else's code. The problem is that it will sometimes return a small amount of text and other times a large amount of text. I need the rows to autofit height. Before I started using the new concatPlusIfs formula, I used a code on the worksheet to autofit row height, but it cause a weird problem with the above code and only the above code and I can't find any mention of this type of problem. It works fine with all other arrays or non array formulas that I'm using. Basically what happens is that for a fraction of a second I can see the correct output in the cell and then I get #value!. I have no idea what's going on. I've tried autofit rows as a macro instead and it had the same effect. If I manually autofit the row everything is fine, but that's not a viable option.
Does anyone understand what would cause a problem like this? Or How can I fix it?
I'm not using any merged rows anywhere on the sheet.
Here are a few of the autofit strategies I've tried. One as a macro:
Sub AutoFit()
Worksheets("Sheet1").Range("A2:A" & Rows.Count).Rows.AutoFit
End Sub
Also as a code on the sheet,
Private Sub Worksheet_Change(ByVal Target As Range)
Target.EntireRow.AutoFit
End Sub
And,
Private Sub Worksheet_Calculate()
Application.EnableEvents = False
Me.Rows.AutoFit
'or be specific
Me.Rows("1:33").AutoFit
Application.EnableEvents = True
End Sub
Thank you for any help with this.
You most likely get #VALUE! error when your formula tries to convert the ### from the .Text property to value. That is why you should use .Value2 or .Value instead.

Excel - User defined function getting is being called even when not active

I have a user defined function in excel. The function contains Application.Volatile at the top and it works great.
The problem I am experiencing now is that when I have the workbook open (lets call it workbook 1) together with another workbook (call it workbook 2), every time I make a change to workbook 2, all cells in workbook 1 that call this UDF gets a #VALUE! error.
Why is this happening?
I hope I provided enough info. If not please let me know.
Thanks
David
Hi guys, thanks for the help.
Sorry about that... here is the code:
Function getTotalReceived(valCell As Range) As Variant
Application.Volatile
If ActiveWorkbook.Name <> "SALES.xlsm" Then Return
Dim receivedWs As Worksheet, reportWs As Worksheet
Dim items As Range
Set reportWs = Worksheets("Report")
Set receivedWs = Worksheets("Received")
Dim myItem As String, index As Long
myItem = valCell.Value
Set items = receivedWs.Range("A:A")
index = Application.Match(myItem, items, 0)
If IsError(index) Then
Debug.Print ("Error: " & myItem)
Debug.Print (Err.Description)
GoTo QuitIt
End If
Dim lCol As Long, Qty As Double, mySumRange As Range
Set mySumRange = receivedWs.Range(index & ":" & index)
Qty = WorksheetFunction.Sum(mySumRange)
QuitIt:
getTotalReceived = Qty
End Function
Your problem is with the use of ActiveWorkbook,ActiveWorksheet or ActiveCell or other Active_____ objects in your UDF. Notice that Application.Volitile is an application-level property. Anytime you switch sheets, books, cells, charts, etc. the corresponding "active" object changes.
As an example of proper UDF coding practice I put together this short example:
Function appCallerTest() As String
Dim callerWorkbook As Workbook
Dim callerWorksheet As Worksheet
Dim callerRange As Range
Application.Volatile True
Set callerRange = Application.Caller
Set callerWorksheet = callerRange.Worksheet
Set callerWorkbook = callerWorksheet.Parent
appCallerTest = "This formula is in cell: " & callerRange.Address(False, False) & _
" in the sheet: " & callerWorksheet.Name & _
" in the workbook: " & callerWorkbook.Name
End Function
Function getTotalReceived(valCell As Range) As Variant
Application.Volatile
Dim index, v, Qty
v = valCell.Value
'do you really need this here?
If ActiveWorkbook.Name <> ThisWorkbook.Name Then Exit Function
If Len(v) > 0 Then
index = Application.Match(v, _
ThisWorkbook.Sheets("Report").Range("A:A"), 0)
If Not IsError(index) Then
Qty = Application.Sum(ThisWorkbook.Sheets("Received").Rows(index))
Else
Qty = "no match"
End If
Else
Qty = ""
End If
getTotalReceived = Qty
End Function
You actually have 2 errors in your function. The first was partially addressed by Mr. Mascaro - you need to use the Range reference that was passed to the function to resolve the Workbook that it is from. You can do this by drilling down through the Parent properties.
The second issue is that you are testing to see if Application.Match returned a valid index with the IsError function. This isn't doing what you think it's doing - IsError checks to see if another cell's function returned an error, not the previous line. In fact, if Application.Match raises an error, it is in your function so you have to handle it. I believe the error you need to trap is a type mismatch (error 13).
This should resolve both issues:
Function getTotalReceived(valCell As Range) As Variant
Application.Volatile
Dim book As Workbook
Set book = valCell.Parent.Parent
If book.Name <> "SALES.xlsm" Then Exit Function
Dim receivedWs As Worksheet, reportWs As Worksheet
Dim items As Range
Set reportWs = book.Worksheets("Report")
Set receivedWs = book.Worksheets("Received")
Dim myItem As String, index As Long
myItem = valCell.Value
Set items = receivedWs.Range("A:A")
On Error Resume Next
index = Application.Match(myItem, items, 0)
If Err.Number = 13 Then GoTo QuitIt
On Error GoTo 0
Dim lCol As Long, Qty As Double, mySumRange As Range
Set mySumRange = receivedWs.Range(index & ":" & index)
Qty = WorksheetFunction.Sum(mySumRange)
QuitIt:
getTotalReceived = Qty
End Function