find workbook names that are in sheet

[RB Smissaert]

Needed a function that finds the Workbook level names
that are in a specified sheet and have put something together, but have a
feeling that there is a better (less code) way to handle this:

Function GetSheetNamedRanges(oSheet As Worksheet) As Variant

'this picks up workbook names that are in the specified sheet
'will need to test for no names found in specified sheet by doing:
'If IsArray(arr) Then
'-----------------------------------------------------------------
Dim i As Long
Dim na As Name
Dim rngSheet As Range
Dim collNames As Collection
Dim arrNames

If ActiveWorkbook.Names.Count > 0 Then

With oSheet
Set rngSheet = .Range(.Cells(1), .Cells(.Rows.Count, Columns.Count))
End With

Set collNames = New Collection

On Error Resume Next
For Each na In ActiveWorkbook.Names
If Not Application.Intersect(rngSheet, Range(na.Name)) Is Nothing Then
If Err.Number = 0 Then
collNames.Add na.Name
i = i + 1
Else
Err.Clear
End If
End If
Next na

If i > 0 Then
ReDim arrNames(1 To i)
For i = 1 To i
arrNames(i) = collNames(i)
Next
GetSheetNamedRanges = arrNames
End If

End If

End Function


Any suggestions to improve on this?


RBS

 

[Jim Thomlinson]

Before I go a whole pile further can you confirm something for me. You only
want workbook level names and not sheet level names included. The reason that
I ask is that your code is including the sheet level names... Try this...

Function GetSheetNamedRanges(oSheet As Worksheet) As Variant

'this picks up workbook names that are in the specified sheet
'will need to test for no names found in specified sheet by doing:
'If IsArray(arr) Then
'-----------------------------------------------------------------
Dim i As Long
Dim na As Name
Dim rngSheet As Range
Dim collNames As Collection
Dim arrNames

If ActiveWorkbook.Names.Count > 0 Then

Set rngSheet = oSheet.Cells

Set collNames = New Collection

On Error Resume Next
For Each na In ActiveWorkbook.Names
If na.Parent.Name = oSheet.Name Then MsgBox na.Name & " is Local"
If na.Parent.Name = ActiveWorkbook.Name Then MsgBox na.Name & " is
Global"

If Not Application.Intersect(rngSheet, Range(na.Name)) Is Nothing Then
If Err.Number = 0 Then
collNames.Add na.Name
i = i + 1
Else
Err.Clear
End If
End If
Next na

If i > 0 Then
ReDim arrNames(1 To i)
For i = 1 To i
arrNames(i) = collNames(i)
Next
GetSheetNamedRanges = arrNames
End If

End If

End Function

 

[RB Smissaert]

Yes, only workbook level names.
In this application I just never use sheet level names, so I don't sheet
level names will appear in these workbooks.
Will check though and thanks for the tip about Parent.Name.

RBS

 

[Jim Thomlinson]

In that case you are looking for names where the parent of the name is the
workbook and the parent of the refered to range is the sheet. So something
like this should do...

Function GetSheetNamedRanges(oSheet As Worksheet) As Variant

'this picks up workbook names that are in the specified sheet
'will need to test for no names found in specified sheet by doing:
'If IsArray(arr) Then
'-----------------------------------------------------------------
Dim i As Long
Dim na As Name
Dim collNames As Collection
Dim arrNames

If ActiveWorkbook.Names.Count > 0 Then
Set collNames = New Collection

For Each na In ActiveWorkbook.Names

If na.RefersToRange.Parent.Name = oSheet.Name And _
na.Parent.Name = ActiveWorkbook.Name Then
collNames.Add na.Name
i = i + 1
End If
Next na

If i > 0 Then
ReDim arrNames(1 To i)
For i = 1 To i
arrNames(i) = collNames(i)
Next
GetSheetNamedRanges = arrNames
End If

End If

End Function

 

[Peter T]

Another one -

Sub test()
Dim arr
MsgBox GetNames(ActiveSheet, arr)
End Sub

Function GetNames(oWsht As Worksheet, arr)
Dim i As Long
Dim nm As Name
Dim ws As Worksheet
ReDim arr(1 To oWsht.Parent.Names.Count)

On Error Resume Next 'RefersToRange error if not be a range name
For Each nm In oWsht.Parent.Names
If InStr(nm.Name, "!") = 0 Then ' not local
Set ws = nm.RefersToRange.Parent
If Not ws Is Nothing Then
If ws Is oWsht Then
i = i + 1
arr(i) = nm.Name
Set ws = Nothing
End If
End If
End If
Next
If i Then
ReDim Preserve arr(1 To i)
End If
GetNames = i
End Function

Regards,
Peter T

 

[RB Smissaert]

Thanks Jim and Peter.
This looks a lot better than using Intersect. Will do a bit of testing
and go with the fastest.

RBS

 

[Peter T]

and go with the fastest.

Typical RBS <g>

Peter T

 

[Jim Thomlinson]

Go with Peter's as it handles named ranges that are actually named formulas.
The code I posted will die an untimely death if it encounters a named
formula...

 

[RB Smissaert]

Yes, I know. Might as well.
Actually as it turns out your code is about 30% faster (even after doing
away with the collection
in Jim's code), so will go with that one.

RBS

 

[RB Smissaert]

Will do and thanks for the trouble taken.
As posted, Peter's code turns out to be quite a bit faster as well.

RBS