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

RBS


"Jim Thomlinson" wrote in message
...
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...
--
HTH...

Jim Thomlinson


"RB Smissaert" wrote:

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

RBS


"Jim Thomlinson" wrote in
message
...
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
--
HTH...

Jim Thomlinson


"RB Smissaert" wrote:

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" wrote in
message
...
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
--
HTH...

Jim Thomlinson


"RB Smissaert" wrote:

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