VBA에서 워크 시트의 위치에 따라 명명 된 범위 항목을 열거하는 방법

Question

워크 시트에서 이름이 지정된 범위를 하나씩 배열했습니다. 각 항목은 하나 개의 명명 된 범위의 이름 인 경우 사용자 정의 폼의 초기화 이벤트 (즉, 목록 상자 포함)에서

, 나는 목록 상자에 항목을 추가 할 수 있습니다.

지금까지 이름이 지정된 범위의 알파벳 순서에 따라 항목을로드하는 것이 관리되었으므로 'a'로 시작하는 이름은 목록의 맨 위에 있고 'z'는 맨 아래에 있습니다.

항목이 워크 시트에 표시된 순서대로 나타나기를 원하기 때문에 A1에 가장 가까운 이름이 지정된 범위가 목록의 맨 위에 나타나고 A1 아래의 명명 된 범위가 두 번째 항목이 될 것입니다. (워크 시트의 맨 아래에있는) 워크 시트의 마지막 명명 된 범위로 이동합니다. 물론 마지막 항목이됩니다.

누구나 우아한 방법을 찾을 수 있습니까?

Answer 1

우아한 해결책인지 확실하지 않지만 간단한 해결책입니다. 아래

코드 범위 이름 셀에 있다고 가정 A1, A2, A3 등의 시트 2와리스트가 빈 셀에 의해 종료된다. 또한 B, C 등의 열에는 아무 것도 없다고 가정합니다. 실제 상황에 맞게 코드를 조정해야합니다.

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에 의해 정렬 한 후, 테이블은 당신이 찾는 순서에있을 것입니다 :

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 

결과는 다섯 열 테이블입니다.

Answer 2

이 시도 :

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