populate array with list of named range

[LetMeDoIt]

Greetings,
I've search several websites (including this forum) and cannot find
any VBA code to perform the following:

I need to populate an array with named ranges. Basically, I need to
search a sheet for defined named ranges, and once found, copy it to
array(i), then on to the next one.

Any help is greatly appreciated....

 

[Bob Phillips]

Dim nme As Name
Dim aryNames As Variant
Dim i As Long

With ActiveWorkbook

If .Names.Count > 0 Then
ReDim aryNames(1 To .Names.Count)
For i = 1 To .Names.Count

aryNames(i) = .Names(i).Name
Next i
End If
End With

--
---
HTH

Bob


(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[Rick Rothstein \(MVP - VB\)]

I find your question somewhat ambiguous. If you are asking to list **all**
the named ranges' names in an array, then Bob's code will do that. However,
if you are asking to list the named ranges on a particular worksheet only,
then consider this code...

Dim X As Long
Dim Index As Long
Dim MyArray() As String
Const SheetName As String = "MySheet1"
With ThisWorkbook
' The next line forces the UBound for an empty MyArray to -1
MyArray = Split("")
If .Names.Count > 0 Then
ReDim MyArray(1 To .Names.Count)
For X = 1 To .Names.Count
If Mid(.Names(X), 2, InStr(.Names(X), "!") - 2) = SheetName Then
Index = Index + 1
MyArray(Index) = .Names(X).Name
End If
Next
ReDim Preserve MyArray(1 To Index)
End If
End With

Note that the worksheet name to find the named ranges on is defined in the
Const statement; change the name to suit your conditions. Also note that my
code force the lower bound of MyArray to -1 while maintaining its upper
bound at 0 if there are no named ranges on the sheet; that way loops won't
generate "Subscript out of range" errors for an empty array and it gives you
a testable condition for the empty array should you want to do that instead.

Rick

 

[Rick Rothstein \(MVP - VB\)]

One minor change to the code I posted... it needs a test to make sure that
even if there were named ranges, at least one of them was on the sheet of
interest (needs to be done on the last ReDim statement). Here is the revised
code...

Sub Test()
Dim X As Long
Dim Index As Long
Dim MyArray() As String
Const SheetName As String = "MySheet1"
With ThisWorkbook
' The next line forces the UBound for an empty MyArray to -1
'MyArray = Split("")
If .Names.Count > 0 Then
ReDim MyArray(1 To .Names.Count)
For X = 1 To .Names.Count
If Mid(.Names(X), 2, InStr(.Names(X), "!") - 2) = SheetName Then
Index = Index + 1
MyArray(Index) = .Names(X).Name
End If
Next
If Index > 0 Then ReDim Preserve MyArray(1 To Index)
End If
End With

 

[Peter T]

You didn't search very hard <g>, here's one posted just a week ago that
appears to do what you want.

Sub test()
Dim ws As Worksheet
Dim arr
ReDim aNames(1 To Worksheets.Count)

For Each ws In ActiveWorkbook.Worksheets
i = i + 1
GetNames ws, arr
aNames(i) = arr
Next

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

In the other thread the OP didn't want to include worksheet level names, I
assume you will hence the commented If test.

Regards,
Peter T

 

[Peter T]

Actually the previously posted function was originally designed with only
one sheet in mind, and not efficient if the purpose is to get all names
sorted into arrays per sheet. Following should work faster in a wb with many
names.

Sub test2()
Dim arr

GetNamesPerSht ActiveWorkbook, arr

End Sub
Function GetNamesPerSht(wb As Workbook, aNames) As Long
Dim i As Long, j As Long, k As Long
Dim nCnt As Long
Dim nm As Name
Dim ws As Worksheet

nCnt = wb.Names.Count
GetNamesPerSht = nCnt
If nCnt = 0 Then Exit Function

ReDim arr1(1 To nCnt, 1 To 2)

On Error Resume Next 'RefersToRange error if not be a range name

' get all range names and mark with parent sheet index
For Each nm In wb.Names

Set ws = nm.RefersToRange.Parent
If Not ws Is Nothing Then
i = i + 1
arr1(i, 1) = nm.Name
arr1(i, 2) = ws.Index
Set ws = Nothing
End If

Next
On Error GoTo 0

ReDim arr2(1 To wb.Worksheets.Count) As Long
ReDim aNames(1 To wb.Worksheets.Count)

' get count of names on each sheet
For i = 1 To UBound(arr1)
arr2(arr1(i, 2)) = arr2(arr1(i, 2)) + 1
Next

'sift names into an array for each sheet
' and add to an array of arrays
For i = 1 To wb.Worksheets.Count
If arr2(i) Then
ReDim arr3(1 To arr2(i))
k = 0
For j = 1 To UBound(arr1)
If i = arr1(j, 2) Then
k = k + 1
arr3(k) = arr1(j, 1)
End If
Next
aNames(i) = arr3
End If
Next

End Function

Regards,
Peter T