在VBA中，如何根据工作表上的位置枚举命名范围条目

Question

我已在工作表中将命名范围逐一排列。

在用户窗体（包含一个列表框）的初始化事件中，当每个条目都是一个命名范围的名称时，我将条目添加到列表框中。

到目前为止，我设法根据命名范围的字母顺序加载列表中的条目，因此以“a”开头的名称位于列表顶部，“z”位于底部。

我希望条目按照它们在工作表中出现的顺序排列，因此靠近 A1 的命名范围将出现在列表的顶部，A1 下的命名范围将是第二个条目，依此类推，直到最后一个命名的条目工作表中的范围（位于工作表底部），这当然将是最后一个条目。

有人能找到一种优雅的方式来做到这一点吗？

Answer 1

试试这个：

Private Sub UserForm_Initialize()
    Dim rCell As Range
    Dim nLoop As Name

    With CreateObject("scripting.dictionary")
        For Each rCell In ActiveSheet.UsedRange.Resize(, 1).Cells
            For Each nLoop In ThisWorkbook.Names
                If Not Intersect(Range(nLoop.RefersTo), Range(rCell.Address)) Is Nothing Then
                    If Not .Exists(nLoop.Name) Then
                        Me.ListBox1.AddItem nLoop.Name
                        .Add (nLoop.Name), Nothing
                        Exit For
                    End If
                End If
            Next
        Next rCell
    End With

End Sub

Answer 2

我不确定这是否是一个优雅的解决方案，但它是一个简单的解决方案。

下面的代码假设范围名称位于 Sheet2 的单元格 A1、A2、A3 等中，并且列表以空白单元格终止。它还假设 B、C 等列中没有任何内容。您必须根据真实情况调整代码。

Sub GetNameDetails()

  Dim Inx As Integer
  Dim NameCrnt As String
  Dim Pos As Integer
  Dim RangeCrnt As String
  Dim RowCrnt As Integer

  RowCrnt = 1
  With Sheets("Sheet2")
    Do While True
      ' This loop is repeated for every cell in column A until it
      ' encounters a blank cell 
      NameCrnt = .Cells(RowCrnt, 1).Value
      If NameCrnt = "" Then Exit Do
      For Inx = 1 To Names.Count
        ' This matches the names in Sheet 2 with the named ranges.
        ' Names that cannot be found in the Names collection are ignored. 
        If Names(Inx).Name = NameCrnt Then
          RangeCrnt = Names(Inx).RefersTo          ' Extract full address of range 
          RangeCrnt = Mid(RangeCrnt, 2)            ' Discard =
          RangeCrnt = Replace(RangeCrnt, "$", "")  ' Remove $s
          Pos = InStr(RangeCrnt, "!")
          ' Save sheet name
          .Cells(RowCrnt, 2).Value = Mid(RangeCrnt, 1, Pos - 1)
          RangeCrnt = Mid(RangeCrnt, Pos + 1)      ' Discard sheet name
          .Cells(RowCrnt, 3).Value = RangeCrnt     ' Save full address of range
          Pos = InStr(RangeCrnt, ":")
          If Pos <> 0 Then
            RangeCrnt = Mid(RangeCrnt, 1, Pos - 1) ' Discard end of range if any
          End If
          .Cells(RowCrnt, 4).Value = .Range(RangeCrnt).Row
          .Cells(RowCrnt, 5).Value = .Range(RangeCrnt).Column
          Exit For
        End If
      Next
      RowCrnt = RowCrnt + 1
    Loop
  End With
End Sub

结果是一个包含五列的表格：

Col 1 = Range name  (unchanged)
Col 2 = Sheet name
Col 3 = Range
Col 4 = Top row of range
Col 5 = Left column of range

按第 4 列和第 5 列排序后，该表格将按照您查找的顺序排列。