I'm trying to determine if a named range has been set via VBA. The named range is called LoadedToken and essentially is loaded when a user clicks a particular button. I use this as proof that initialisation has taken place.
I have a function to check if this has taken place:
Function ToolIsEnabled()
' We check if the R2A add-in has been loaded by detecting the named range
If ActiveWorkbook.Names("LoadedToken") Is Nothing Then
ToolIsEnabled = False
Else
ToolIsEnabled = True
End If
End Function
and I get an application error. Of course, the VBA is incorrect. However how can I actually accomplish this?!
Sub Test()
Debug.Print IsNamedRange("Bumsti")
End Sub
Function IsNamedRange(RName As String) As Boolean
Dim N As Name
IsNamedRange = False
For Each N In ActiveWorkbook.Names
If N.Name = RName Then
IsNamedRange = True
Exit For
End If
Next
End Function
Usage in OP context could be
' ...
If IsNamedRange("LoadedToken") Then
' ...
End If
' ...
or - if a program specific Bool needs to be set
' ...
Dim IsTokenLoaded as Boolean
IsTokenLoaded = IsNamedRange("LoadedToken")
' ...
Both constructs make it pretty clear in the source code what you are aiming for.
You can achieve this by using error handling:
Function ToolIsEnabled() As Boolean
Dim rng As Range
On Error Resume Next
Set rng = ActiveWorkbook.Range("LoadedToken")
On Error GoTo 0
ToolIsEnabled = Not rng is Nothing
End Function
This will check either in ThisWorkbook or a named workbook and return TRUE/FALSE.
Sub Test()
MsgBox NamedRangeExists("SomeName")
MsgBox NamedRangeExists("SomeOtherName", Workbooks("Book1.xls"))
End Sub
Public Function NamedRangeExists(sName As String, Optional Book As Workbook) As Boolean
On Error Resume Next
If Book Is Nothing Then
Set Book = ThisWorkbook
End If
NamedRangeExists = Book.Names(sName).Index <> (Err.Number = 0)
On Error GoTo 0
End Function
Edit:
A shorter version if it's only going to look in ThisWorkbook:
Public Function NamedRangeExists(sName As String) As Boolean
On Error Resume Next
NamedRangeExists = ThisWorkbook.Names(sName).Index <> (Err.Number = 0)
On Error GoTo 0
End Function
For the activeworkbook, you could also call the old XLM NAMES() function:
Function IsNameInActiveWorkbook(sName As String) As Boolean
IsNameInActiveWorkbook = Not IsError(Application.ExecuteExcel4Macro("MATCH(""" & sName & """,NAMES(),0)"))
End Function
As per Tom's answer these 2 line should do the trick:
On Error Resume Next
Set TestRange = ActiveWorkbook.Range("LoadedToken") 'if it does **not** exist this line will be ERROR
Related
I am trying to create a subroutine that will take a collection of a bunch of strings, step through it, and check for the existence of a named range or formula that has that string as it's name. Trying it with just one item first:
Dim colCritNames As New Collection
colCritNames.Add "Version" 'the name of a named formula
For i = 1 To colCritNames.Count
nm = CStr(colCritNames(i).Name)
nmchk = Check_UW_For_Name(nm)
If Not nmchk Then Call Fail("Critical Name") 'prints a msgbox with the error type so I know what happened
Next i
'...code for if all the names are there...
Function Check_UW_For_Name(find_name As String) As Boolean
Dim wb As Workbook
Set wb = UserFileBook 'global ref to the workbook to check
On Error Goto Fail
Check_UW_For_Name = CBool(Len(wb.Names(find_name).Name) <> 0)
On Error GoTo 0
End Function
Thats edited from the full thing. Check_UW_For_Name was working fine when I just called it with "Version" as the argument Check_UW_For_Name("Version"); it found it in USerFIleBook, and when I called it with "Nope", since there is no Nope name it went to my error handler. But when I try to use a collection to store the names I want to look for I keep getting 'ByRef argument mismatch'. I tried just nm = colCritNames(i) and nm=colCritNames(i).Name, I tried having find_name be Variant and adding a ByVal, and I originally tried having nm be a Name, having Check_UW_For_Name(find_name as Name) and using a for each (for each nm in colCritNames...) and none of it has worked.
How could I set a collection of names and step through it to see if there's a named range/formula that matches in the relevant workbook? Or is there a better way to do this? (I need the collection in other places too)
I don't quite understand what your plan is with a collection, but this will add any cell with the specified string in, as well as any ranges. What you're doing once they've been identified (added to collection) is not clear to me, but hopefully this makes sense and gets you going.
Sub RunForEachString()
Const yourStrings = "foo,bar,hope,this,works"
Dim stringsAsArray() As String
stringsAsArray = Split(yourStrings, ",")
Dim i As Long
For i = LBound(stringsAsArray) To UBound(stringsAsArray)
Call findAllNamesFormulas(stringsAsArray(i), ThisWorkbook)
Next i
End Sub
Private Sub findAllNamesFormulas(theText As String, theWorkbook As Workbook)
Dim ws As Worksheet, n As Name, aCell As Range
Dim aCollection As New Collection
For Each ws In ThisWorkbook.Worksheets
For Each aCell In ws.UsedRange.Cells
If InStr(1, aCell.Formula, theText, vbTextCompare) > 0 Then
aCollection.Add (aCell)
End If
Next aCell
Next ws
For Each n In ThisWorkbook.Names
If InStr(1, n.Name, theText, vbTextCompare) > 0 Then
aCollection.Add (n)
End If
Next n
'not sure what you plan to do after collection?
Debug.Print aCollection.Count
End Sub
This works for me:
Sub Tester()
Dim colCritNames As New Collection, nm, wb As Workbook, msg As String
colCritNames.Add "Version"
colCritNames.Add "NotThere"
colCritNames.Add "AlsoNotThere"
Set wb = ThisWorkbook 'for example
For Each nm In colCritNames
If Not Check_UW_For_Name(wb, CStr(nm)) Then
msg = msg & vbLf & " - " & nm
End If
Next nm
If Len(msg) > 0 Then
MsgBox "One or more required names are missing:" & msg, _
vbExclamation, "Oops"
Exit Sub
End If
'proceed if OK...
End Sub
'check for a defined Name `find_name` in workbook `wb`
' prefer wb as parameter over using a Global....
Function Check_UW_For_Name(wb As Workbook, find_name As String) As Boolean
On Error Resume Next
Check_UW_For_Name = (wb.Names(find_name).Name = find_name)
End Function
You could create a collection of all named ranges in the workbook like this:
Private Sub NamedRangesDemo()
Dim NamedRanges As New Collection, NamedRange As Variant
For Each NamedRange In ThisWorkbook.Names
NamedRanges.Add NamedRange.Name
Next NamedRange
End Sub
And then compare the whatever strings you want to the NamedRanges collection.
By the way, this question is somewhat similar to yours.
When the code is applied to a pivot table that has no PageRange property the code fails with the error in the title
I tried to apply a boolean variable to
sh.PivotTables(i).PageRange
but that did not work either
Sub TestPivotPaste2()
Dim wb As Workbook
Dim sh As Worksheet
Set wb = ActiveWorkbook
Set sh = wb.Worksheets(7)
c = sh.PivotTables.Count
If c > 0 Then
For i = 1 To c
If Not sh.PivotTables(i).PageRange.Count = 0 Then
Debug.Print c
Else
GoTo nextpiv
End If
nextpiv:
Next i
Else
MsgBox ("NoPivot")
End If
End Sub
the expected result is to be able to discern the pivot tables where the PageRange property is true or false, but it only works when the range exists.
Try this function
Function pageRangeExists(pt as PivotTable) as Boolean
Dim test as Range
On Error Resume Next
Set test = pt.PageRange
On Error Go To 0
pageRangeExists = Not test Is Nothing
End Function
Since PageRange is a range object, you have to test if the range exists or is valid first, as trying to act against a range that is not there will produce an error.
And with that your for loop can be simplified
For i = 1 To c
If pageRangeExists(sh.PivotTables(i)) Then
Debug.Print c
End If
Next i
The GoTo statement is superfluous as it is logic already embedded in a for loop.
I've written a VBA function that takes two parameters, the first is a string and the 2nd is a range, specified in the sheet as:
=strPack(B1,G3)
In the code, this routine is declared as:
Public Function strPack(ByVal strHex As String, ByRef rngCnt As Range) As String
On Error Goto ErrHandler
If False Then
ErrHandler:
MsgBox Err.Description
Exit Function
End If
Dim intCnt As Integer
intCnt = 0
'...do something with strHex and increment intCnt whilst we go
rngCnt.Value = CStr(intCnt)
'strPack is populated by the body of the function
strPack = "Hello World"
End Function
I've tried .Value, .Value2 and .Text, all result in an error:
Application-defined or object-defined error
When I look in the debugger, both strHex and rngCnt are valid and correct. Why can't I assign to the range and how do I fix it?
The error handler is not the problem, try it out, it works perfectly well and is a standard way of picking up errors and aborting a function when an error occurs.
[Edit] I've just tried the following:
Public Sub updateCount()
Worksheets("Sheet1").Range("G3").Value = CStr(intProcessed)
End Sub
intProcessed is global to the module and is an integer, result is the same, exactly the same error.
[Edit2] I want to remove this post as I've changed the approach now to call another subroutine that returns a value which is dropped into the cell. I can't delete it! Thank you to all for your help.
See the code comments:
Public Function strPack(ByVal strHex As String, ByVal rngCnt As Range) As String
Dim lRes As Long
On Error GoTo errHandler
lRes = 1000 '==> Your business logic goes here
'/ This is the gymnastics you do to update range from an UDF
Application.Evaluate ("UpdateRange(" & rngCnt.Address & "," & lRes & ")")
strPack = "SUCCESSFULL"
errHandler:
If Err.Number <> 0 Then
strPack = "FAILED"
End If
End Function
'/ Helper to allow range update from UDF
Private Function UpdateRange(rngDest As Range, val As Variant)
rngDest.Value = val
End Function
These if ... then statements are getting the wrong results in my opinion. The first is returning the value 'false' when it should be 'true'. The fourth returns the right value. The second and third return an error.
Sub empty_array()
Dim arr1() As Variant
If IsEmpty(arr1) Then
MsgBox "hey"
End If
If IsError(UBound(arr1)) Then
MsgBox "hey"
End If
If IsError(Application.match("*", (arr1), 0)) Then
MsgBox "hey"
End If
ReDim arr1(1)
arr1(1) = "hey"
If IsEmpty(arr1) Then
MsgBox "hey"
End If
End Sub
Arr1 becomes an array of 'Variant' by the first statement of your code:
Dim arr1() As Variant
Array of size zero is not empty, as like an empty box exists in real world.
If you define a variable of 'Variant', that will be empty when it is created.
Following code will display "Empty".
Dim a as Variant
If IsEmpty(a) then
MsgBox("Empty")
Else
MsgBox("Not Empty")
End If
Adding into this: it depends on what your array is defined as. Consider:
dim a() as integer
dim b() as string
dim c() as variant
'these doesn't work
if isempty(a) then msgbox "integer arrays can be empty"
if isempty(b) then msgbox "string arrays can be empty"
'this is because isempty can only be tested on classes which have an .empty property
'this do work
if isempty(c) then msgbox "variants can be empty"
So, what can we do? In VBA, we can see if we can trigger an error and somehow handle it, for example
dim a() as integer
dim bEmpty as boolean
bempty=false
on error resume next
bempty=not isnumeric(ubound(a))
on error goto 0
But this is really clumsy... A nicer solution is to declare a boolean variable (a public or module level is best). When the array is first initialised, then set this variable.
Because it's a variable declared at the same time, if it loses it's value, then you know that you need to reinitialise your array.
However, if it is initialised, then all you're doing is checking the value of a boolean, which is low cost. It depends on whether being low cost matters, and if you're going to be needing to check it often.
option explicit
'declared at module level
dim a() as integer
dim aInitialised as boolean
sub DoSomethingWithA()
if not aInitialised then InitialiseA
'you can now proceed confident that a() is intialised
end sub
sub InitialiseA()
'insert code to do whatever is required to initialise A
'e.g.
redim a(10)
a(1)=123
'...
aInitialised=true
end sub
The last thing you can do is create a function; which in this case will need to be dependent on the clumsy on error method.
function isInitialised(byref a() as variant) as boolean
isInitialised=false
on error resume next
isinitialised=isnumeric(ubound(a))
end function
#jeminar has the best solution above.
I cleaned it up a bit though.
I recommend adding this to a FunctionsArray module
isInitialised=false is not needed because Booleans are false when created
On Error GoTo 0 wrap and indent code inside error blocks similar to with blocks for visibility. these methods should be avoided as much as possible but ... VBA ...
Function isInitialised(ByRef a() As Variant) As Boolean
On Error Resume Next
isInitialised = IsNumeric(UBound(a))
On Error GoTo 0
End Function
I would do this as
if isnumeric(ubound(a)) = False then msgbox "a is empty!"
I may be a bit late, but following simple stuff works with string arrays:
Dim files() As String
files = "..." 'assign array
If Not Not files Then
For i = LBound(files) To UBound(files)
'do stuff, array is not empty
Next
End If
That's all the code for this.
Above methods didn´t work for me. This did:
Dim arrayIsNothing As Boolean
On Error Resume Next
arrayIsNothing = IsNumeric(UBound(YOUR_ARRAY)) And False
If Err.Number <> 0 Then arrayIsNothing = True
Err.Clear
On Error GoTo 0
'Now you can test:
if arrayIsNothing then ...
this worked for me:
Private Function arrIsEmpty(arr as variant)
On Error Resume Next
arrIsEmpty = False
arrIsEmpty = IsNumeric(UBound(arr))
End Function
The problem with VBA is that there are both dynamic and static arrays...
Dynamic Array Example
Dim myDynamicArray() as Variant
Static Array Example
Dim myStaticArray(10) as Variant
Dim myOtherStaticArray(0 To 10) as Variant
Using error handling to check if the array is empty works for a Dynamic Array, but a static array is by definition not empty, there are entries in the array, even if all those entries are empty.
So for clarity's sake, I named my function "IsZeroLengthArray".
Public Function IsZeroLengthArray(ByRef subject() As Variant) As Boolean
'Tell VBA to proceed if there is an error to the next line.
On Error Resume Next
Dim UpperBound As Integer
Dim ErrorNumber As Long
Dim ErrorDescription As String
Dim ErrorSource As String
'If the array is empty this will throw an error because a zero-length
'array has no UpperBound (or LowerBound).
'This only works for dynamic arrays. If this was a static array there
'would be both an upper and lower bound.
UpperBound = UBound(subject)
'Store the Error Number and then clear the Error object
'because we want VBA to treat unintended errors normally
ErrorNumber = Err.Number
ErrorDescription = Err.Description
ErrorSource = Err.Source
Err.Clear
On Error GoTo 0
'Check the Error Object to see if we have a "subscript out of range" error.
'If we do (the number is 9) then we can assume that the array is zero-length.
If ErrorNumber = 9 Then
IsZeroLengthArray = True
'If the Error number is something else then 9 we want to raise
'that error again...
ElseIf ErrorNumber <> 0 Then
Err.Raise ErrorNumber, ErrorSource, ErrorDescription
'If the Error number is 0 then we have no error and can assume that the
'array is not of zero-length
ElseIf ErrorNumber = 0 Then
IsZeroLengthArray = False
End If
End Function
I hope that this helps others as it helped me.
I'm using this
If UBound(a) >= 0 Then
' not empty
Else
' empty... UBound(a) = -1
End If
IsEmpty(a) did not work for me... I hate VBA
Dim arr() As Variant
Debug.Print IsEmpty(arr) ' False
Debug.Print UBound(arr) ' raises error
arr = Array()
Debug.Print IsEmpty(arr) ' False
Debug.Print UBound(arr) ' -1
ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr)) = "test"
Debug.Print IsEmpty(arr) ' False
Debug.Print UBound(arr) ' 0
The below function works for both static and dynamic arrays.
Function array_Empty(testArr As Variant) As Boolean
Dim i As Long, k As Long, flag As Long
On Error Resume Next
i = UBound(testArr)
If Err.Number = 0 Then
flag = 0
For k = LBound(testArr) To UBound(testArr)
If IsEmpty(testArr(k)) = False Then
flag = 1
array_Empty = False
Exit For
End If
Next k
If flag = 0 Then array_Empty = True
Else
array_Empty = True
End If
End Function
Tente isso:
Function inic(mtz As Variant) As Boolean
On Error Resume Next
Dim x As Boolean
x = UBound(mtz): inic = x
End Function
...
if inic(mymtz) then
debug.print "iniciada"
else
debug.print "não iniciada"
end if
I'm currently trying to trace the dependencies of a complex set of Excel spreadsheets. My ideal end goal would be a tree structure, starting with my first spreadsheet. However, I don't want to include all of the dependencies of the child spreadsheets, just the ones of the cells referenced by the original spreadsheet. For example:
In cell A1 of my first workbook:
somebook.xls!Sheet1!C2
I want to look at cell C2 in sheet 1 of somebook.xls for its (external) dependencies, and then recurse.
At the moment I'm using LinkInfo to get a list of external dependencies, searching using Find, and I'm struggling with vbscript's primitive regex capabilities to try and extract the address out of the cells I find. This is not a brilliant way of doing things.
Does anyone know if Excel will tell you which cells in an external spreadsheet are being referenced? If not, any other tools that might help?
Thanks.
This answer is based off Bill Manville's macro from many years back. The macro still works, but I broke it out into functions allowing for more flexibility and reusability. The main addition by me is the ability to find external dependencies only, and the extension to both precedents and dependents. I also added a call to a custom macro called unhideAll; this was necessary for me as dependencies were not being found in hidden worksheets.
'Module for examining depedencies to/from a sheet from/to other sheets
Option Explicit
Sub showExternalDependents()
Dim deps As Collection
Set deps = findExternalDependents(ActiveCell)
Call showDents(deps, True, "External Dependents: ")
End Sub
Sub showExternalPrecedents()
Dim precs As Collection
Set precs = findExternalPrecedents(ActiveCell)
Call showDents(precs, True, "External Precedents: ")
End Sub
'external determines whether or not to print out the absolute address including workbook & worksheet
Sub showDents(dents As Collection, external As Boolean, header As String)
Dim dent As Variant
Dim stMsg As String
stMsg = ""
For Each dent In dents
stMsg = stMsg & vbNewLine & dent.Address(external:=external)
Next dent
MsgBox header & stMsg
End Sub
Function findPrecedents(rng As Range) As Collection
Set findPrecedents = findDents(rng, True)
End Function
Function findDependents(rng As Range) As Collection
Set findDependents = findDents(rng, False)
End Function
Function findExternalPrecedents(rng As Range) As Collection
Set findExternalPrecedents = findExternalDents(rng, True)
End Function
Function findExternalDependents(rng As Range) As Collection
Set findExternalDependents = findExternalDents(rng, False)
End Function
'Gives back only the dependencies that are not on the same sheet as rng
Function findExternalDents(rng As Range, precDir As Boolean) As Collection
Dim dents As New Collection
Dim dent As Range
Dim d As Variant
Dim ws As Worksheet
Set ws = rng.Worksheet
For Each d In findDents(rng, precDir)
Set dent = d
With dent
If Not (.Worksheet.Name = ws.Name And .Worksheet.Parent.Name = ws.Parent.Name) Then _
dents.Add Item:=dent
End With
Next d
Set findExternalDents = dents
End Function
'this procedure finds the cells which are the direct precedents/dependents of the active cell
'If precDir is true, then we look for precedents, else we look for dependents
Function findDents(rng As Range, precDir As Boolean) As Collection
'Need to unhide sheets for external dependencies or the navigate arrow won't work
Call mUnhideAll
Dim rLast As Range, iLinkNum As Integer, iArrowNum As Integer
Dim dents As New Collection
Dim bNewArrow As Boolean
'Appliciation.ScreenUpdating = False
If precDir Then
ActiveCell.showPrecedents
Else
ActiveCell.ShowDependents
End If
Set rLast = rng
iArrowNum = 1
iLinkNum = 1
bNewArrow = True
Do
Do
Application.Goto rLast
On Error Resume Next
ActiveCell.NavigateArrow TowardPrecedent:=precDir, ArrowNumber:=iArrowNum, LinkNumber:=iLinkNum
If Err.Number > 0 Then Exit Do
On Error GoTo 0
If rLast.Address(external:=True) = ActiveCell.Address(external:=True) Then Exit Do
bNewArrow = False
dents.Add Item:=Selection
iLinkNum = iLinkNum + 1 ' try another link
Loop
If bNewArrow Then Exit Do
iLinkNum = 1
bNewArrow = True
iArrowNum = iArrowNum + 1 'try another arrow
Loop
rLast.Parent.ClearArrows
Application.Goto rLast
Set findDents = dents
End Function
Sub mUnhideAll()
'
' mUnhideAll Macro
'
' Unhide All
Dim ws As Worksheet
For Each ws In Worksheets
ws.Visible = True
Next
'Sheets("Sprint Schedule Worksheet").Visible = False
End Sub
Excel's built in support, as you're finding, is limited and can be extremely frustrating.
In my experience, I've found a couple of tools from http://www.aivosto.com/ to be useful; Visustin v6 is especially useful for code related auditting/processing.
Here's a simpler version of Colm Bhandal's findDents and findExternalDents. It assumes all worksheets were made visible and arrows were cleared before use.
Function findDents(rCell As Range, bPrec As Boolean) As Collection
'Return all direct precedents (bPrec=True) or dependents (bPrec=False) of rCell
Dim sAddr As String, nLink As Integer, nArrow As Integer
Const bAbs As Boolean = False, bExt As Boolean = True
Set findDents = New Collection
If bPrec Then
rCell.showPrecedents ' even if rCell has no formula
Else
rCell.showDependents
End If
On Error Resume Next ' ignore errors
sAddr = rCell.Address(bAbs, bAbs, xlA1, bExt)
nArrow = 1
Do
nLink = 1
Do
rCell.NavigateArrow bPrec, nArrow, nLink
If ActiveCell.Address(bAbs, bAbs, xlA1, bExt) = sAddr Then Exit Do
findDents.Add Selection ' possibly more than one cell
nLink = nLink + 1
Loop
If nLink = 1 Then Exit Do
nArrow = nArrow + 1
Loop
On Error GoTo 0
If bPrec Then
rCell.showPrecedents Remove:=True
Else
rCell.showDependents Remove:=True
End If
End Function
Function findExternalDents(rCell As Range, bPrec As Boolean) As Collection
'Return ...Dents that are NOT in the same workbook and worksheet as rCell
Dim rDent As Range, wsName As String, wbName As String
With rCell.Worksheet: wsName = .Name: wbName = .Parent.Name: End With
Set findExternalDents = New Collection
For Each rDent In findDents(rCell, bPrec)
If rDent.Worksheet.Name <> wsName Or rDent.Worksheet.Parent.Name <> wbName Then findExternalDents.Add Item:=rDent
Next rDent
End Function
You might want to modify this to use a SortedList instead of a Collection. In that case, change
findDents.Add Selection
to
findDents.Add Selection.Address(bAbs, bAbs, xlA1, bExt), Null