トップ > 逆引きで学ぶ ユーザーフォーム&コントロール > 追加章　現場で活かせる！実践ユーザーフォーム > B-02　AND・OR検索フォームを作る

Sub Form_Show() 'フォーム表示
    UserForm1.Show vbModeless 'モードレス表示設定
End Sub

Option Explicit

'--------------------------------------------
' コマンドボタンClickイベント
'--------------------------------------------
Private Sub CommandButton1_Click()
    'テキストボックス1の値（キーワード）を 余分な空白を削除しstrTextに代入
    Dim strText As String
    strText = WorksheetFunction.Trim(TextBox1.Value)
    
    'テキストボックスが空欄であれば終了
    If Len(strText) = 0 Then
        MsgBox "キーワードを入力してください", vbInformation
        Exit Sub
    End If
    
    'キーワードを配列化
    Dim varKeyWord As Variant 'キーワード
    If InStr(1, strText, " ", vbTextCompare) = 0 Then
        ReDim varKeyWord(0): varKeyWord(0) = strText
    Else
        varKeyWord = Split(strText, " ", , vbTextCompare)
    End If
    
    '検索開始
    Dim r As Range '検索対象格納セル
    Call Find_AND_OR(ActiveSheet, r, varKeyWord, CBool(OptionButton1.Value))

    '検索対象が見つからなければ終了
    If r Is Nothing Then
        MsgBox "検索対象が見つかりません", vbInformation
        Exit Sub
    End If

    '新規ブック（出力用）を追加追加し結果を出力
    With Workbooks.Add.Worksheets(1)
        Union(r.EntireRow, r.EntireRow).Copy '該当セルの行を適切な形に集合しコピー
        .Cells(1, "A").PasteSpecial Paste:=xlPasteValues '新規ブックに値貼り付け
        Application.CutCopyMode = False      'コピー状態を解除
        .UsedRange.Columns.AutoFit           '列幅オートフィット
    End With
    Set r = Nothing
    Unload Me
End Sub

'--------------------------------------------
' オプションボタンClickイベント
'--------------------------------------------
Private Sub OptionButton1_Click()
    TextBox1.SetFocus 'テキストボックスにフォーカスを移す
End Sub

Private Sub OptionButton2_Click()
    TextBox1.SetFocus
End Sub

'--------------------------------------------
' 検索
'--------------------------------------------
'［引数］
'   Sh        ：検索対象シート
'   r         ：検索結果設定セル
'   varKeyWord：キーワードを格納した配列
'   f         ：True：AND検索　False：OR検索
'--------------------------------------------
Private Sub Find_AND_OR(ByRef Sh As Worksheet, _
                        ByRef r As Range, _
                        ByVal varKeyWord As Variant, _
                        ByVal f As Boolean)
    Dim i          As Long    'カウンタ
    Dim v          As Variant
    Dim strAddress As String  'セルアドレス格納用
    Dim rngFnd     As Range   '検索一致セル
    ReDim rngUni(UBound(varKeyWord)) As Range 'セル集合用
    
    For Each v In varKeyWord  '配列varKeyWordから順に値を取得し検索
        Set rngFnd = Sh.Cells.Find(What:=v, LookAt:=xlPart) '検索
        If Not rngFnd Is Nothing Then
            strAddress = rngFnd.Address '最初に検索一致したセルのアドレスを代入
            Set rngUni(i) = rngFnd
            Do
                Set rngUni(i) = Union(rngUni(i), rngFnd) 'セルを集合
                Set rngFnd = Sh.Cells.FindNext(rngFnd)   '次の一致セルを検索
                'セルアドレスが最初に一致したセルアドレスと同じの場合は抜ける
            Loop Until strAddress = rngFnd.Address
            i = i + 1
        End If
        Set rngFnd = Nothing
    Next
    
    If i = 0 Then Exit Sub
    
    Dim rng As Range
    Set rng = rngUni(0)
    
    If f Then 'AND検索
        For i = 0 To UBound(varKeyWord)
            If rngUni(i) Is Nothing Then Exit Sub
            Set rng = Intersect(rng, rngUni(i)) '共通セルを取得
        Next
    Else      'OR検索
        For i = 0 To UBound(varKeyWord)
            Set rng = Union(rng, rngUni(i))     'セルを集合
        Next
    End If
    Set r = rng
End Sub

書籍紹介140以上のサンプルファイル付き！

知りたいがすぐわかる！　やりたいがすぐできる！
「Excel VBA 逆引きで学ぶ ユーザーフォーム&コントロール」（Kindle版）
ユーザーフォームを扱えると、VBAでできることが大きく広がります！
本書では、知りたいこと、やりたいことから、逆引きで学びを深められます。

■ 購入：amazon