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

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

Related

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.

VBA: Display "NA" in cell on error

With below code I am calculating the RSS. It does however happen that the Y range does not actually contain values. I have surpassed the error (Run-time error '1004') that displays when there aren't any values with 'on error goto next' but then it just 'copies' the same value as the previous one in the destination cell when there wouldn't actually be any.
Is there a way to display "NA" in stead of the previous value in the destination cell where the RSS cannot be calculated due to a lack of Y values?
Thank you in advance
Private Sub Regr(strWksData As String, WsTools As Worksheet, strWksFF3 As String, strWksResult As String)
Dim NoOfRow As Long
Dim i As Integer
Dim sData As Worksheet
Dim sFF3 As Worksheet
Dim sResult As Worksheet
Dim rX1 As Range
Dim rY1 As Range
'General
Set sData = Sheets("Return")
Set sFF3 = Sheets("FF-3")
Set sResult = Sheets("Result")
'Set X ranges
Set rX1 = sFF3.Range("C2:E21")
'Set Y ranges
Set rY1 = sData.Range("F2:F21")
'Loop through columns
'Provide statistic
On Error GoTo ErrorHandling
For i = 0 To 5
vStat1 = Application.WorksheetFunction.LinEst(rY1.Offset(0, i), rX1, True, True)
sResult.Range("F2").Offset(0, i).Value = vStat1(5, 2)
NoOfRow = rY1.Rows.Count
WsTools.Range("B2").Value = NoOfRow
Next i
ErrorHandling:
Resume Next
On Error GoTo 0
MsgBox ("RSS Done")
End Sub
Since you are writing the results directly to the worksheet, just take advantage of the different error reporting behavior of Application.LinEst v. Application.WorksheetFunction.LinEst.
When you call the fully qualified WorksheetFunction, any error raised in the called function is thrown as a run-time error:
Debug.Print Application.WorksheetFunction.Sum("a", "b") '<--runtime error 1004
When you use the extensible interface on Application, any error raised in the called function is returned wrapped in a Variant:
Debug.Print Application.Sum("a", "b") '<--Prints Error 2015 (#VALUE!)
If you need to test to see whether or not it's an error, you can use the IsError function:
Dim v As Variant
v = Application.Sum("a", "b")
Debug.Print IsError(v) '<-- True
In your case, you can just write the error value directly to the cell:
For i = 0 To 5
Dim result As Variant
result = Application.LinEst(rY1.Offset(0, i), rX1, True, True)
'Don't attempt to use the indexer on an error.
If IsError(result) Then
sResult.Range("F2").Offset(0, i).Value = result
Else
sResult.Range("F2").Offset(0, i).Value = result(5, 2)
End If
Next

VBA - worksheet parameter in function

I have a function 'mergeCategories' taking into argument (worksheet, worksheet, long). The idea is to read the value of a cell and replace it with another value based on a mapping table.
The content of the function works well when I run it as a sub and declaring the values inside the sub. But when i call the function from a sub, i get error Run-time error 424 Object Required at the line:
last_row_matching = ws_matching.Range("A1").End(xlDown).Row
Apparently, there is an issue with the worksheet ws_matching
Here is the function:
Function mergeCategories(ws_source As Worksheet, ws_macthing As Worksheet, last_row_used As Long) As Boolean
'Variables
'Result boolean
Dim final_result As Boolean
final_result = False
'Source category name
Dim src_cat_name As String
'Destination category name
Dim dest_cat_name As String
'Index of last row in matching table
Dim last_row_matching As Long
last_row_matching = ws_matching.Range("A1").End(xlDown).Row
MsgBox "Last row matching " & last_row_matching
'Result of the matching (as range, .Value used to get name)
Dim result_range As Range
'Loop
For i = 1 To last_row_used
'get the source category name
src_cat_name = ws_source.Range("A" & i).Value
MsgBox "The category name pulled is " & src_cat_name
'Find the mapping
Set result_range = ws_matching.Range("A2:A" & last_row_matching).Find(src_cat_name)
dest_cat_name = result_range.Offset(0, 1).Value
MsgBox "The new category name is " & dest_cat_name
ws_source.Range("A" & i).Value = dest_cat_name
ws_source.Range("A" & i).Activate
MsgBox "Check"
Next i
final_result = True
End Function
Here is the macro:
Sub test_mergeCategories()
Dim ws_matching As Worksheet
Set ws_matching = Sheets("Matching")
Dim ws_source As Worksheet
Set ws_source = Sheets("Temp_Import")
Dim last_row_used As Long
last_row_used = ws_source.Range("A1").End(xlDown).Row
Call mergeCategories(ws_source, ws_matching, last_row_used)
End Sub
Any idea of what is the issue?

Copy named ranges to the active sheet

I'm trying to copy named ranges from the Wk1 worksheet to the active sheet in the workbook.
I keep getting error messages when I run the code. They either say an Object is not set or a variable has not been declared.
Sub ChangeNamedRangesOnNewWKsheet()
Dim RangeName As Name
Dim HighlightRange As Range
Dim RangeName2 As String
Dim NewRangeName As String
Dim Ws As Worksheets
Dim cs As Worksheet
Set cs = Application.ActiveSheet
''''' Delete invalid named ranges
For Each RangeName In ActiveWorkbook.Names
If InStr(1, RangeName.RefersTo, "#REF!") > 0 Then
RangeName.Delete
End If
Next RangeName
For Each RangeName In Ws
If InStr(1, RangeName, "Wk1", 1) > 0 Then
Set HighlightRange = RangeName.RefersToRange
NewRangeName = Replace(RangeName.Name, "Wk1", "cs.Name")
RangeName2 = Replace(RangeName, "='Wk1'", "'cs.Name'")
On Error Resume Next
HighlightRange.Copy Destination:=Worksheets("cs.Name").Range(RangeName2)
Range(RangeName2).Name = NewRangeName
On Error GoTo 0
End If
Next RangeName
MsgBox "Done"
End Sub
Ive changed the code to this. Im not getting error messages but the code is still not working. the named ranges are not copying from the Wk1 sheet to the Active sheet. The only thing that happens is that the Message Box Opens
Sub ChangeNamedRangesOnNewWKsheet()
Dim RangeName As Name
Dim HighlightRange As Range
Dim RangeName2 As String
Dim NewRangeName As String
Dim Cs As Worksheet
Set Cs = Application.ActiveSheet
''''' Delete invalid named ranges
For Each RangeName In ActiveWorkbook.Names
If InStr(1, RangeName.RefersTo, "#REF!") > 0 Then
RangeName.Delete
End If
Next RangeName
For Each RangeName In ActiveWorkbook.Names
If InStr(1, RangeName, "Wk1", 1) > 0 Then
Set HighlightRange = RangeName.RefersToRange
NewRangeName = Replace(RangeName.Name, "Wk1", "cs.Name")
RangeName2 = Replace(RangeName, "='Wk1'", "'cs.Name'")
On Error Resume Next
HighlightRange.Copy Destination:=Worksheets("cs.Name").Range(RangeName2)
Range(RangeName2).Name = NewRangeName
On Error GoTo 0
End If
Next RangeName
MsgBox "Done"
End Sub
Took me some time to figure out whats not working when there is no error, but finally I think I managed to figure out the issue.
Replace the following line in your code
HighlightRange.Copy Destination:=Worksheets("cs.Name").Range(RangeName2)
to:
HighlightRange.Copy Destination:=Worksheets(cs.Name).Range(HighlightRange.Address)
This should give you desired result.
Syntax for Copy to destination is Destination:=Worksheets("sheet_name").Range(range). Here sheet_name should be the name of the sheet. So when you write Worksheets("cs.Name") code looks for the sheet named cs.Name which actually does not exist hence just use Worksheets(cs.Name). Second thing here is range (just to explain things better I am using $A$1:$A$5 as range). When you write .Range(RangeName2) code is looking for 'cs.Name'!$A$1:$A$5. Again this is incorrect because range should be written as .Range($A$1:$A$5). So .Range(HighlightRange.Address) will give you the proper range.
You can also play out in the line RangeName2 = Replace(RangeName, "='Wk1'", "'cs.Name'") to get proper address.
Hope this helps.
EDIT :
__________________________________________________________________________________
example of what i want. copy the named range Wk1Totalhrs from Wk1 sheet to Wk2-Wk7 sheets so that Wk1Totalhrs becomes Wk2Totalhrs,Wk3Totalhrs etc on the corresponding new sheet
Try the following code to achieve what you mentioned as your requirement in comment (or as above).
Sub ChangeNamedRangesOnNewWKsheet()
Dim RangeName As Name
Dim HighlightRange As Range
Dim RangeName2 As String, NewRangeName As String, SearchRange As String
Dim MyWrkSht As Worksheet, cs As Worksheet
Set MyWrkSht = ActiveWorkbook.Worksheets("Wk1")
SearchRange = "Wk1Totalhrs" '---> enter name of the range to be copied
''''' Delete invalid named ranges
For Each RangeName In MyWrkSht.Names
If InStr(1, RangeName.RefersTo, "#REF!") > 0 Then
RangeName.Delete
End If
Next RangeName
'For Each RangeName In MyWrkSht.Names ActiveWorkbook.Names
For Each RangeName In ActiveWorkbook.Names
If RangeName.Name = SearchRange Then '---> search for the named range Wk1Totalhrs
Set HighlightRange = RangeName.RefersToRange
For Each cs In ActiveWorkbook.Sheets
Debug.Print cs.Name
If cs.Name <> "Wk1" Then '---> don't do anything in the sheet Wk1
NewRangeName = Replace(RangeName.Name, "Wk1", cs.Name)
RangeName2 = Replace(RangeName, "='Wk1'", cs.Name)
HighlightRange.Copy Destination:=Worksheets(cs.Name).Range(HighlightRange.Address)
Range(RangeName2).Name = NewRangeName
End If
Next cs
End If
Next RangeName
End Sub
I think it's just as simple as this.
Public Sub ShowNames()
Dim Nm As Name
Dim i As Long
For Each Nm In ActiveWorkbook.Names
i = i + 1
Range("A1").Offset(i, 0).Value = Nm
Next Nm
End Sub
Im not getting error messages but the code is still not working.the named ranges are not copying from the Wk1 sheet to the Active sheet.
The following line will return false positives when the named range starts with or contains WK10, WK11, etc.
If InStr(1, RangeName, "Wk1", 1) > 0 Then
A little further down, you are quoting a variable property; this makes it a literal string, not the value of the variable property.
NewRangeName = Replace(RangeName.Name, "Wk1", "cs.Name")
You need a more concrete way to identify the defined names on WK1. After looking closely at your problem, I believe that you may have one or more dynamic named ranges that are defined by formulas. This would explain some of the 'not working' behavior of your code that should be working with more conventional ReferTo: properties.
There is also the problem of whether you should rewrite the RefersTo: of an existing defined named range or add a new named range. One common practise is to simply attempt to delete the named range un On Error Resume Next and then create a new one. I've never liked this method for a variety of reasons; one being that deleting a named range will make dependent named ranges refer to #REF! and I've never considered on error resume next to be a 'best practise'.
The following builds a dictionary of keys containing named ranges to be created and ones that already exist using multiple criteria. I've tested this repeatedly on a combination of conventional and dynamic named ranges with success.
Option Explicit
Sub ChangeNamedRangesOnNewWKsheet()
Dim nm As Name
Dim rtr As String, nm2 As String
Dim w As Long
Dim k As Variant, dict As Object
Set dict = CreateObject("Scripting.Dictionary")
dict.comparemode = vbTextCompare
With ActiveWorkbook
'Delete invalid named ranges and build dictionary of valid ones from WK1
For Each nm In .Names
If CBool(InStr(1, nm.RefersTo, "#REF!", vbTextCompare)) Or _
CBool(InStr(1, nm.RefersTo, "#NAME?", vbTextCompare)) Then
'Debug.Print nm.Name
On Error Resume Next
nm.Delete
Err.Clear
On Error GoTo 0
ElseIf LCase(Left(nm.Name, 3)) = "wk1" And _
(CBool(InStr(1, nm.RefersTo, "wk1!", vbTextCompare)) Or _
CBool(InStr(1, nm.RefersTo, "'wk1'!", vbTextCompare))) Then
dict.Item(Mid(nm.Name, 4)) = LCase(nm.RefersTo)
ElseIf LCase(Left(nm.Name, 2)) = "wk" Then
dict.Item(nm.Name) = LCase(nm.RefersTo)
End If
Next nm
For w = 1 To Worksheets.Count
With Worksheets(w)
If LCase(.Name) <> "wk1" And Left(LCase(.Name), 2) = "wk" Then
For Each k In dict
If dict.exists(.Name & k) Then
.Parent.Names(.Name & k).RefersTo = _
Replace(LCase(dict.Item(k)), "wk1", .Name, 1, -1, vbTextCompare)
ElseIf Left(LCase(k), 2) <> "wk" Then
.Parent.Names.Add _
Name:=.Name & k, _
RefersTo:=Replace(LCase(dict.Item(k)), "wk1", .Name, 1, -1, vbTextCompare)
End If
Next k
End If
End With
Next w
End With
dict.RemoveAll: Set dict = Nothing
'MsgBox "All worksheets done"
End Sub
Note that this creates/redefines all named ranges on all worksheets (other than WK1). As far as I can determine, the only chance to have false positives would be to have an existing named range with a name something like WK1wkrange (but that would just be silly).
This code works
Public Sub CopyNamedRanges()
Dim namedRange As Name
Dim targetRefersTo As String
Dim targetName As String
On Error Resume Next
For Each namedRange In ActiveWorkbook.Names
If Left$(namedRange.RefersTo, 6) = "='Wk1'" And Left$(namedRange.Name, 3) = "Wk1" Then
targetName = Replace(namedRange.Name, "Wk1", ActiveSheet.Name)
targetRefersTo = Replace(namedRange.RefersTo, "Wk1", ActiveSheet.Name)
ActiveWorkbook.Names.Add targetName, targetRefersTo ' Might error if it already exists
ActiveWorkbook.Names(targetName).RefersTo = targetRefersTo
namedRange.RefersToRange.Copy Range(targetName) ' Remove this line if it's not required
End If
Next
End Sub
How the code works
This part If Left$(namedRange.RefersTo, 6) = "='Wk1'"
makes sure that the range refers to some cells on the sheet called Wk1
The other condition (Left$(namedRange.Name, 3) = "Wk1") would also match named ranges on sheets Wk10 - Wk19.
This part ActiveWorkbook.Names.Add targetName, targetRefersTo will adds a new named range that refers to the cells on the current sheet
This part namedRange.RefersToRange.Copy Range(targetName) copies the contents of the named range on the Wk1 sheet to the current sheet (remove the line if you don't need it)
Dim RangeName As Variant Try changing the variable type

Find cell based on a property

I need to find a cell into a worksheet but I'd like to avoid looking for a string.
The problem I have is that the worksheet will be edited by my client. If ever he decides to write the string I'm looking for before the good one, the app will crash.
Sub FindSpecificCell()
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("TP 1")
Dim myRange As Range
Dim rangeFinal As Range
Set monRange = ws.Range("A:AJ")
Set rangeFinal = myRange.Find("Description du test")
Debug.Print " "
Debug.Print "Looking for ""Description du test"" in TP 1 "
Debug.Print "column : " & rangeFinal.Column
Debug.Print "row : " & rangeFinal.Row
End Sub
Is there a way to insert a kind of property inside the cell in order to be sure that I'm working on the good one?
You can't associated properties with a specific cell directly, but you can use properties with the worksheet to store this information. I've used a couple methods like this before:
'Set the provided value of the custom property with the provided name in the provided sheet.
Private Sub SetCustomPropertyValue(InSheet As Worksheet, WithPropertyName As String, WithValue As Variant)
Dim objCP As CustomProperty
Dim bolFound As Boolean
bolFound = False 'preset.
For Each objCP In InSheet.CustomProperties
'if this property's name is the one whose value is sought...
If (StrComp(objCP.Name, WithPropertyName, vbTextCompare) = 0) Then
objCP.Value = WithValue
bolFound = True
Exit For
End If
Next
'if the property didn't already exist on the sheet, add it.
If (Not bolFound) Then Call InSheet.CustomProperties.Add(WithPropertyName, WithValue)
End Sub
'Return the value of the custom property with the provided name in the provided sheet.
Private Function GetCustomPropertyValue(InSheet As Worksheet, WithPropertyName As String) As Variant
Dim objCP As CustomProperty
GetCustomPropertyValue = Empty
For Each objCP In InSheet.CustomProperties
'if this property's name is the one whose value is sought...
If (StrComp(objCP.Name, WithPropertyName, vbTextCompare) = 0) Then
GetCustomPropertyValue = objCP.Value
Exit For
End If
Next
End Function
Then you can do something like this to write and read back values:
Sub test()
Dim strPropName As String
strPropName = "MyRange_" & Selection.Address
Dim strWhatIWantToStore As String
strWhatIWantToStore = "Here's what I want to store for this range"
Call SetCustomPropertyValue(ActiveSheet, strPropName, strWhatIWantToStore)
MsgBox GetCustomPropertyValue(ActiveSheet, strPropName)
End Sub