'読み仮名のリストボックスでフィルタをするサンプルマクロ

'リスト用範囲は、読み仮名の昇順に並べ替え済みであることが前提です。
'MakeSampleSheetマクロを実行後、MyDialogShowマクロを実行してください。


Option Explicit

'ダイアログシートの名前
Const DialogSheetName As String = "顧客選択"

'リスト範囲（項目見出し1行を含めます。）
Const ListRangeName As String = "顧客選択リスト!A1"

'リスト表示用列の番号
Const ListDisplayColumn As Integer = 2


'リストボックスの入力範囲を示す変数
'ダイアログボックス表示前に必ず設定してください。
Dim ListRange As Range

'リストインデックス基準値を示す変数
'実際のリストインデックス = ListIndexBase + .ListIndex です。
Dim ListIndexBase As Long


'フォーム表示時マクロ
Sub Form1_Show()

    'オプションボタンとリストボックスの初期設定
    With ActiveDialog.OptionButtons(1)
        .Value = xlOn
        SetListFillRange .Text
    End With
End Sub

'オプションボタンクリック時マクロ
Sub OptionButtons_Click()
    Dim s As String

    'オプションボタンのテキストを取得
    s = ActiveDialog.DrawingObjects(Application.Caller).Text
    If s = "英数" Then s = " "

    'リストボックスの入力範囲の設定
    SetListFillRange s
End Sub

'リストボックスの入力範囲を設定するマクロ
Sub SetListFillRange(string1 As String)
    Dim list1 As Object
    Dim range1 As Range

    Set list1 = ActiveDialog.ListBoxes(1)

    '指定文字の区間のセル範囲を取得
    Set range1 = MyGetListRange(string1)

    'リストボックス入力範囲の設定
    If range1 Is Nothing Then
        list1.ListFillRange = ""
        ListIndexBase = 0
    Else
        list1.ListFillRange = range1.Address(external:=True)
        list1.ListIndex = 1
        ListIndexBase = range1.Row - ListRange.Row
    End If
End Sub

'指定文字の区間のセル範囲を取得する関数
Function MyGetListRange(string1 As String) As Range
    Dim ch1 As String, ch2 As String, s As String
    Dim i As Long, j As Long, k As Long

    '検索文字（ch1とch2）の取得
    s = "あかさたなはまやらわ"
    ch1 = Left$(string1, 1)
    i = InStr(1, s, ch1, 0)
    Select Case i
        Case 0
            ch1 = ""
            ch2 = Left$(s, 1)
        Case Len(s)
            ch2 = ""
        Case Else
            ch2 = Mid$(s, i + 1, 1)
    End Select

    '先頭位置の検索
    i = MyMatch(ch1, ListRange)

    '最終位置+1の検索
    If Len(ch2) = 0 Then
        j = ListRange.Rows.Count + 1
    Else
        j = i + MyMatch(ch2, ListRange.Cells(i, 1).Resize( _
            ListRange.Rows.Count - i + 1)) - 1
    End If

    'セル範囲を返す
    k = j - i
    If k > 0 Then
        Set MyGetListRange = ListRange.Cells(i, 1).Resize(k)
    Else
        Set MyGetListRange = Nothing
    End If
End Function

'指定文字以上のセルを検索する関数（セル範囲最終+1を返す場合もあります）
Function MyMatch(string1 As String, range1 As Range) As Long
    Dim v As Variant
    Dim ch As String
    If Len(string1) = 0 Then
        MyMatch = 1
    Else
        ch = Left$(string1, 1)
        v = Application.Match(ch, range1, 1)
        If Application.IsError(v) Then
            MyMatch = 1
        Else
            If range1.Cells(v, 1).Value = ch Then
                MyMatch = v
            Else
                MyMatch = v + 1
            End If
        End If
    End If
End Function

'リスト範囲を並び替えるマクロ
Sub MyRangeSort()
    Const myTitle As String = DialogSheetName
    Dim r As Range

    On Error Resume Next
    Set r = Application.Evaluate(ListRangeName).Cells(1, 1).CurrentRegion
    On Error GoTo 0
    If r Is Nothing Then
        MsgBox "リスト範囲が取得できません。", vbExclamation, myTitle
    ElseIf r.Columns.Count < ListDisplayColumn Then
        MsgBox "表示列の指定が不正です。", vbExclamation, myTitle
    ElseIf r.Rows.Count = 1 Then
        MsgBox "リストにデータがありません。", vbExclamation, myTitle
    Else
        'リスト範囲を並び替える
        r.SortSpecial SortMethod:=xlSyllabary, _
            Key1:=r.Cells(2, ListDisplayColumn), Order1:=xlAscending, _
            Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
            Orientation:=xlTopToBottom
    End If
End Sub


'ダイアログボックスを表示するマクロ
Sub MyDialogShow()
    Const myTitle As String = DialogSheetName
    Dim i As Long
    Dim r As Range

    'リスト範囲の設定
    On Error Resume Next
    Set r = Application.Evaluate(ListRangeName) _
        .Cells(1, 1).CurrentRegion.Columns(ListDisplayColumn)
    On Error GoTo 0
    If r Is Nothing Then
        MsgBox "リスト範囲が取得できません。", vbExclamation, myTitle
        Exit Sub
    Else
        i = r.Rows.Count
        If i = 1 Then
            MsgBox "リストにデータがありません。", vbExclamation, myTitle
            Exit Sub
        Else
            Set ListRange = r.Resize(i - 1).Offset(1)
        End If
    End If

    'リストインデックス基準値の初期化
    ListIndexBase = 0

    'ダイアログボックスの表示
    With DialogSheets(DialogSheetName)
        If .Show Then

            '実際のリストインデックスの取得
            i = ListIndexBase + .ListBoxes(1).ListIndex
            If i > 0 Then

                '選択項目の表示
                MsgBox ListRange.Cells(i).Value, , myTitle
            End If
        End If
    End With
End Sub

'サンプルシートを作成するマクロ
Sub MakeSampleSheet()
    Dim dlg As DialogSheet
    Dim gw As Double
    Dim i As Integer
    Dim s As String

    'ワークシートの作成
    With Worksheets.Add
        .Name = DialogSheetName & "リスト"
        .Range("A1:B1").Value = Array("名前", "よみ")
        .Range("A2:B2").Value = Array("Name1", "123A")
        .Range("A3:B3").Value = Array("NameA", "ABC")
        For i = 177 To 220
            s = StrConv(Chr$(i), vbWide Or vbHiragana)
            .Cells((i - 177) * 10 + 4, 1).Resize(10, 2).Value _
                = Array("Name" & s, s & "あいう")
        Next
    End With

    'ダイアログシートの作成
    s = "あかさたなはまやらわ"
    Set dlg = DialogSheets.Add
    dlg.Name = DialogSheetName
    gw = dlg.Buttons(1).Height / 3
    With dlg.DialogFrame
        .Left = gw * 13: .Top = gw * 4
        .Width = gw * 66: .Height = gw * 28
        .Caption = DialogSheetName
        .OnAction = "Form1_Show"
    End With
    dlg.DrawingObjects.Delete
    For i = 1 To 10
        With dlg.OptionButtons.Add( _
            Left:=gw * (15 + ((i - 1) \ 5) * 8), _
            Top:=gw * (10 + ((i + 4) Mod 5) * 3), _
            Width:=gw * 8, Height:=gw * 3)
            .Caption = Mid$(s, i, 1)
        End With
    Next
    With dlg.OptionButtons.Add(Left:=gw * 23, _
        Top:=gw * 25, Width:=gw * 8, Height:=gw * 3)
        .Caption = "英数"
    End With
    dlg.GroupBoxes.Add(Left:=gw * 14, Top:=gw * 8, _
        Width:=gw * 20, Height:=gw * 22).Caption = ""
    dlg.OptionButtons.OnAction = "OptionButtons_Click"
    dlg.ListBoxes.Add Left:=gw * 35, Top:=gw * 8, _
        Width:=gw * 32, Height:=gw * 23
    With dlg.Buttons.Add(Left:=gw * 68, Top:=gw * 8, _
        Width:=gw * 10, Height:=gw * 3)
        .Caption = "OK"
        .DismissButton = True
        .DefaultButton = True
    End With
    With dlg.Buttons.Add(Left:=gw * 68, Top:=gw * 12, _
        Width:=gw * 10, Height:=gw * 3)
        .Caption = StrConv("キャンセル", vbNarrow)
        .CancelButton = True
    End With
    MyRangeSort
End Sub