Making an array

[doctorhifi]

Would someone tell me how to utilize an array or array(s) to speed this up?

Set wsOutput = Sheets("NamedRanges")

With wsOutput

.Cells(1, "A") = "Name of all named range"

.Cells(1, "B") = "Address"

.Cells(1, "C") = "Row"

.Cells(1, "D") = "Column"

.Cells(1, "E") = "Value"

.Range(.Cells(1, "A"), .Cells(1, "E")).Font.Bold = True

End With



With ThisWorkbook



For Each nme In .Names

i = 0



On Error Resume Next

If Range(nme.Name).Worksheet.Name <> "Pricing Worksheet" Then GoTo skip



datastring2 = Range(nme.Name).Address(ReferenceStyle:=xlR1C1)

SearchString = ":"

i = InStr(1, datastring2, SearchString, vbTextCompare)



If i <> 0 Then

i = i - 1

datastring1 = Left(datastring2, i)

Else

datastring1 = Range(nme.Name).Address(ReferenceStyle:=xlR1C1)

End If



SearchString = "C"

z = InStr(1, datastring1, SearchString, vbTextCompare)

rope = Left(Range(nme.Name).Address(ReferenceStyle:=xlR1C1), z - 1)

Rope2 = Right(rope, Len(rope) - 1)

If Rope2 > 190 Then GoTo skip



Rope3 = Right(Len(datastring1), Len(datastring1) - i)

If Rope3 > 30 Then GoTo skip



On Error GoTo 0



With wsOutput

Set rngDestin = .Cells(.Rows.count, "A").End(xlUp).Offset(1, 0)

End With

On Error Resume Next

rngDestin = nme.Name

rngDestin.Offset(0, 1) = Range(nme.Name).Address(ReferenceStyle:=xlR1C1)

rngDestin.Offset(0, 2) = Rope2

rngDestin.Offset(0, 3) = Rope3

rngDestin.Offset(0, 4) = nme.Value



On Error GoTo 0

skip:

Next nme



End With



wsOutput.Columns.AutoFit



End Sub

 

[DanteAmor]

I attach 2 macros, try each of them to see which one improves your time.

Macro 1

Sub macro_v1()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long, j As Long, nRow As Long, nCol As Long, lr As Long, lc As Long
  Dim a As Variant, b As Variant, c As Variant
  Dim addr As String

  Set sh1 = Sheets("Pricing Worksheet")
  Set sh2 = Sheets("NamedRanges")
  lr = sh1.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
  lc = sh1.Cells.Find("*", , xlValues, xlPart, xlByColumns, xlPrevious).Column
  c = sh1.Range("A1", sh1.Cells(lr, lc)).Value
  
  sh2.Range("H2").ListNames
  a = sh2.Range("H2", sh2.Range("I" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a, 1), 1 To 5)
  
  For i = 1 To UBound(a)
    If InStr(1, a(i, 2), "'Pricing Worksheet'") > 0 Then
      addr = Split(a(i, 2), "!")(1)
      nRow = Replace(Split(a(i, 2), "$")(2), ":", "")
      nCol = Columns(Split(a(i, 2), "$")(1)).Column
      addr = Application.ConvertFormula(Formula:=addr, fromreferencestyle:=xlA1, toreferencestyle:=xlR1C1)
      
      If nRow <= 190 And nCol <= 30 Then
        j = j + 1
        b(j, 1) = a(i, 1)
        b(j, 2) = addr
        b(j, 3) = nRow
        b(j, 4) = nCol
        b(j, 5) = c(nRow, nCol)
      End If
    End If
  Next
  
  With sh2.Range("A1")
    .Resize(1, 5).Value = Array("Name of all named range", "Address", "Row", "Column", "Value")
    .Resize(1, 5).Font.Bold = True
    .Offset(1).Resize(UBound(b, 1), UBound(b, 2)).Value = b
  End With
End Sub

Macro 2

Sub macro_v2()
  Dim i As Long, nCount As Long, nRow As Long, nCol As Long
  Dim nme As Name
  Dim a As Variant

  nCount = ThisWorkbook.Names.Count
  ReDim a(1 To nCount, 1 To 5)

  For Each nme In ThisWorkbook.Names
    If Range(nme.Name).Worksheet.Name = "Pricing Worksheet" Then
      nRow = Range(nme.Name).Cells(1).Row
      nCol = Range(nme.Name).Cells(1).Column
      If nRow <= 190 And nCol <= 30 Then
        i = i + 1
        a(i, 1) = nme.Name
        a(i, 2) = Range(nme.Name).Address(ReferenceStyle:=xlR1C1)
        a(i, 3) = nRow
        a(i, 4) = nCol
        a(i, 5) = Range(nme.Name).Cells(1).Value
      End If
    End If
  Next
  
  With Sheets("NamedRanges").Range("A1")
    .Resize(1, 5).Value = Array("Name of all named range", "Address", "Row", "Column", "Value")
    .Resize(1, 5).Font.Bold = True
    .Offset(1).Resize(UBound(a, 1), UBound(a, 2)).Value = a
    .Resize(1, 5).EntireColumn.Columns.AutoFit
  End With
End Sub

----- --
I hope to hear from you soon.
Respectfully
Dante Amor
----- --

 

[doctorhifi]

Dante thanks for your response.
Macro v1 runs without error but does not output any data to the Row, Column or Value columns on the NamedRanges sheet. And it also doesn't skip the named ranges associated with worksheets other than Pricing Worksheet
Macro v2 creates error 1004 method range of object_global failed for this line:

 If Range(nme.Name).Worksheet.Name = "Pricing Worksheet" Then

so I am unable to test it

 

[DanteAmor]

Do you really have named ranges on the "Pricing Worksheet" sheet?

Run this macro and tell me what appears in the "NamedRanges" sheet

Sub test()
  Sheets("NamedRanges").Range("A2").ListNames
End Sub

 

[doctorhifi]

it results in 9,819 lines showing all named ranges from the entire workbook.
Example of a few of these lines:

ACdropdownList	='Misc items'!$L$2:$L$5
ACdropdownList2	='Misc items'!$L$3:$L$5
AcrovynBumperText	='Pricing Worksheet'!$Q$348
AcrovynHandrailText	='Pricing Worksheet'!$Q$347
AcrovynRange	='Pricing Worksheet'!$AF$345
AddAnS	='Pricing Worksheet'!$D$316
AddForExtraTLabor	='Pricing Worksheet'!$W$907
AddForExtraTMatl	='Pricing Worksheet'!$W$908
AddForTtext	='Pricing Worksheet'!$Z$908
AddForXtraSectionsText	='Pricing Worksheet'!$Z$907
AdditionalStud	='Handrails D 2021'!$AN$49

 

[doctorhifi]

Dante, I think the issue is that all but four of the named ranges on the Pricing Worksheet are Global in scope so would be in the global name list and not on the local sheet name list. The only local sheet named ranges are some print preview named ranges.

 

[DanteAmor]

Thanks for the example.

In your example all the rows are greater than 190.
In your macro you have this condition:

If Rope2 > 190 Then GoTo skip

Then all the named ranges have the row greater than 190, that is why it does not put data.

Then try macro1:

Sub macro_v1()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long, j As Long, nRow As Long, nCol As Long, lr As Long, lc As Long
  Dim a As Variant, b As Variant, c As Variant
  Dim addr As String

  Set sh1 = Sheets("Pricing Worksheet")
  Set sh2 = Sheets("NamedRanges")
  lr = sh1.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
  lc = sh1.Cells.Find("*", , xlValues, xlPart, xlByColumns, xlPrevious).Column
  c = sh1.Range("A1", sh1.Cells(lr, lc)).Value
  
  sh2.Range("H2").ListNames
  a = sh2.Range("H2", sh2.Range("I" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a, 1), 1 To 5)
  
  For i = 1 To UBound(a)
    If InStr(1, a(i, 2), "'Pricing Worksheet'") > 0 Then
      addr = Split(a(i, 2), "!")(1)
      nRow = Replace(Split(a(i, 2), "$")(2), ":", "")
      nCol = Columns(Split(a(i, 2), "$")(1)).Column
      addr = Application.ConvertFormula(Formula:=addr, fromreferencestyle:=xlA1, toreferencestyle:=xlR1C1)
      
      'If nRow <= 190 And nCol <= 30 Then
        j = j + 1
        b(j, 1) = a(i, 1)
        b(j, 2) = addr
        b(j, 3) = nRow
        b(j, 4) = nCol
        b(j, 5) = c(nRow, nCol)
      'End If
    End If
  Next
  
  With sh2.Range("A1")
    .Resize(1, 5).Value = Array("Name of all named range", "Address", "Row", "Column", "Value")
    .Resize(1, 5).Font.Bold = True
    .Offset(1).Resize(UBound(b, 1), UBound(b, 2)).Value = b
  End With
End Sub

 

[DanteAmor]

To recreate your scenario, can you confirm if you have 1 or 2 books.

What is the name of each book?

Which book is each sheet in?

In which book do you have the macro?

Etc.

 

[doctorhifi]

I have only one Excel workbook open and each sheet is in that one workbook.
I modified the code and it is now working for me.
Runs in <1 second.
Thanks very much, Dante!

Sub ListNamedRanges()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.enableevents = False
Application.DisplayAlerts = False
Dim StartTime As Double
Dim SecondsElapsed As Double

'Remember time when macro starts
  StartTime = Timer
  
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long, j As Long, nRow As Long, nCol As Long, lr As Long, lc As Long
  Dim a As Variant, b As Variant, c As Variant
  Dim addr As String

  Set sh1 = Sheets("Pricing Worksheet")
  Set sh2 = Sheets("NamedRanges")
  lr = sh1.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
  lc = sh1.Cells.Find("*", , xlValues, xlPart, xlByColumns, xlPrevious).Column
  c = sh1.Range("A1", sh1.Cells(lr, lc)).Value
  
  sh2.Range("H2").ListNames
  Range("H2:I2", Range("i2").End(xlDown)).Sort Key1:=Range("i2"), Order1:=xlAscending, Header:=xlNo
  
  a = sh2.Range("H2", sh2.Range("I" & Rows.count).End(3)).Value
  ReDim b(1 To UBound(a, 1), 1 To 5)
'Stop
  'For i = 1 To UBound(a)
For i = 1 To UBound(a)
 
 If InStr(1, a(i, 2), "'Pricing Worksheet'") > 0 Then
      addr = Split(a(i, 2), "!")(1)
On Error Resume Next
      nRow = Replace(Split(a(i, 2), "$")(2), ":", "")
      nCol = Columns(Split(a(i, 2), "$")(1)).Column
      addr = Application.ConvertFormula(formula:=addr, fromreferencestyle:=xlA1, toreferencestyle:=xlR1C1)

      If nRow <= 190 And nCol <= 30 Then
        j = j + 1
        b(j, 1) = a(i, 1)
        b(j, 2) = addr
        b(j, 3) = nRow
        b(j, 4) = nCol
        b(j, 5) = c(nRow, nCol)
      End If
 End If
  
skip:
Next
  
 On Error GoTo 0
 

     With sh2.Range("A1")
    .Resize(1, 5).Value = Array("Name of all named range", "Address", "Row", "Column", "Value")
    .Resize(1, 5).Font.Bold = True
    .Offset(1).Resize(UBound(b, 1), UBound(b, 2)).Value = b
     End With
theend:

'Determine how many seconds code took to run
  SecondsElapsed = Round(Timer - StartTime, 2)

'Notify user in seconds
   MsgBox "Successful." & vbNewLine & vbNewLine & "This code ran successfully in " & Round(SecondsElapsed, 4) & " seconds", vbInformation, "List Named Ranges"


Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.enableevents = True
Application.DisplayAlerts = True

End Sub