uf3


リストボックスの上に絞り込み用のTextBoxを配置し、「ふりがな」で絞り込みを行う。
例では、商品テーブルの商品に「ふりがな」列を作っておき、絞り込みの文字(ひらがな)と比較する。


TextBoxの文字を一文字入力する度にListBox内のリストが絞り込まれる。逆に一文字づつ消しても同様。
全ての文字を消した場合には、ListBoxを初期状態へ再表示して全てのリストを表示する。

元の商品リストと別に、絞り込み用の表をプログラム内で作成し、それをListBoxに表示し直すので、元のリストは壊れない。


以下は、TextBoxに入力してListBoxが絞り込まれるプログラム。

===========================

Private Sub TextBox1_Change() 
    Dim r As Long
    Dim lngEndRow As Long

    Application.ScreenUpdating = False
    
    'テキストボックが空だったら、ListBoxに全てのリストを表示して終了
    If TextBox1.Text = "" Then
    
        r = Application.Rows.Count
        lngEndRow = Sheets(Sht_work2).Cells(r, "A").End(xlUp).Row
    
        If lngEndRow < 2 Then
            ListBox2.RowSource = ""
        Else
            ListBox2.RowSource = Sht_work2 & "!A2:B" & lngEndRow
        End If
    
        Exit Sub
    End If
    
    'テキストボックに入力があったら、絞り込みを行う
    Call 商品情報をふりがな入力で絞り込みLB1
    
End Sub

===========================

Sub 商品情報をふりがな入力で絞り込みLB1() 
    Dim strActiveCellAddress As String
    Dim strThisSheetName As String
    
    Dim r As Long
    Dim lngEndRow As Long
    Dim i As Long
    
    Dim Serch_ID As String
    Dim Dat_SerchArea As String
    Dim firstAddress As String
    Dim c As Range
    
    Application.ScreenUpdating = False
    
    strActiveCellAddress = ActiveCell.Address
    strThisSheetName = ActiveSheet.Name
    
    '--------------------------------------------------
    '       振込情報をワークシートにコピー
    '--------------------------------------------------
    
    '商品リストの最終行を求める
    r = Application.Rows.Count
    lngEndRow = Sheets(Sht_work2).Cells(r, "A").End(xlUp).Row

    '商品リストがない→終了
    If lngEndRow < 2 Then
        ListBox2.RowSource = ""
        Exit Sub
    End If

    '絞り込んだデータはJ:K列にコピーするので、コピー先をクリアしておく
    Sheets(Sht_work2).Columns("J:K").ClearContents

    '絞り込みキーワードをTextBoxから得る
    Serch_ID = TextBox1.Text
    
    '検索先の列を指定
    Dat_SerchArea = "C1:C" & lngEndRow

    '--------------------------------------------------
    ' TextBox1のTextと ふりがな が部分一致したらコピー
    '--------------------------------------------------
    
    i = 1
    
    '商品の表タイトルだけ先に絞り込み表へコピー
    Sheets(Sht_work2).Range("A" & i & ":C" & i).Copy
    Sheets(Sht_work2).Range("J" & i).PasteSpecial Paste:=xlValue
    Application.CutCopyMode = False
    
    '見出し部分を消して、見出し行から検索しないと並び順が狂う。
    Sheets(Sht_work2).Range("C1").ClearContents
    
    '絞り込み検索して部分一致した商品データを、絞り込み後の表へコピーしていく
    With Worksheets(Sht_work2).Range(Dat_SerchArea)
        
        Set c = .Find(Serch_ID, LookIn:=xlValues, lookat:=xlPart, matchbyte:=False)
        If Not c Is Nothing Then
        
            firstAddress = c.Address
            i = i + 1
            
            Sheets(Sht_work2).Range("A" & c.Row & ":C" & c.Row).Copy
            Sheets(Sht_work2).Range("J" & i).PasteSpecial Paste:=xlValue
            Application.CutCopyMode = False
                      
            Do
                
                Set c = .FindNext(c)
                
                If c.Address <> firstAddress Then
                    i = i + 1
                    Sheets(Sht_work2).Range("A" & c.Row & ":C" & c.Row).Copy
                    Sheets(Sht_work2).Range("J" & i).PasteSpecial Paste:=xlValue
                    Application.CutCopyMode = False
                End If
            
            Loop While Not c Is Nothing And c.Address <> firstAddress

        End If
    
    End With

    '絞り込み後の表の最終行を確認し、一致したデータあった場合は、ListBoxに再表示
    lngEndRow = Sheets(Sht_work2).Cells(r, "J").End(xlUp).Row
    If lngEndRow < 2 Then
        ListBox2.RowSource = ""
    Else
        ListBox2.RowSource = Sht_work2 & "!J2:K" & lngEndRow
    End If
    
    Sheets(strThisSheetName).Select
    Range(strActiveCellAddress).Select
    
End Sub