0

ワークシートで上下に配置された範囲に名前を付けました。

ユーザーフォーム (リストボックスを含む) の初期化イベントで、各エントリが 1 つの名前付き範囲の名前である場合、リストボックスにエントリを追加します。

これで、名前付き範囲のアルファベット順に従ってエントリをリストにロードできたので、「a」で始まる名前がリストの一番上にあり、「z」が一番下にあります。

エントリをワークシートに表示される順序にしたいので、A1 に近い名前付き範囲がリストの一番上に表示され、A1 の下の名前付き範囲が 2 番目のエントリになり、最後に名前が付けられた範囲まで続きます。ワークシートの範囲 (ワークシートの下部) はもちろん最後のエントリになります。

誰でもこれを行うエレガントな方法を見つけることができますか?

4

2 に答える 2

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
于 2011-12-05T19:33:00.487 に答える
0

これがエレガントな解決策であるかどうかはわかりませんが、単純な解決策です。

以下のコードは、範囲名が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

結果は5列のテーブルです。

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列目で並べ替えると、テーブルは目的の順序になります。

于 2011-12-04T17:03:45.057 に答える