Excel VBAでユーザーフォームから複数キーワード検索して新シートに抽出する方法

Visual Basic

Excel VBAを使えば、ユーザーフォームのテキストボックスに入力した複数のキーワードをもとに、Sheet1のデータを検索し、条件に合う行だけを新しいシートに抽出することが可能です。キーワードの数が変動しても対応できる柔軟な方法をご紹介します。

処理の基本の流れ

この処理では主に以下のステップで実装します。

  • ユーザーフォームのテキストボックスからキーワード文字列を取得
  • 全角スペースで区切り、配列としてキーワードを準備
  • Sheet1の各行をループし、すべてのキーワードが含まれるかチェック
  • 条件を満たす行を新しいシートにコピー

サンプルVBAコード

Private Sub CommandButton1_Click()
    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim lastRow As Long, destRow As Long
    Dim keywords() As String, i As Long, j As Long
    Dim textBoxValue As String, rowMatches As Boolean

    ' 元データのシート
    Set wsSrc = ThisWorkbook.Sheets("Sheet1")
    ' 新しいシートを作成
    Set wsDest = ThisWorkbook.Sheets.Add
    wsDest.Name = "抽出結果"

    ' キーワード取得（全角スペースで分割）
    textBoxValue = Me.TextBox1.Value
    keywords = Split(textBoxValue, "　")  ' 全角スペース

    ' 最終行取得
    lastRow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row
    destRow = 1

    ' ヘッダーをコピー（必要なら）
    wsSrc.Range("A1:E1").Copy wsDest.Range("A1")
    destRow = destRow + 1

    ' データ行をループ
    For i = 2 To lastRow
        rowMatches = True
        ' キーワードごとに行内のA〜E列をチェック
        For j = LBound(keywords) To UBound(keywords)
            If Application.WorksheetFunction.CountIf(wsSrc.Range("A" & i & ":E" & i), "*" & keywords(j) & "*") = 0 Then
                rowMatches = False
                Exit For
            End If
        Next j

        ' 条件を満たす場合、コピー
        If rowMatches Then
            wsSrc.Range("A" & i & ":E" & i).Copy wsDest.Range("A" & destRow)
            destRow = destRow + 1
        End If
    Next i

    MsgBox "抽出完了！"
End Sub

ポイントの解説

・Split関数で全角スペースを区切り文字として使用しているため、複数キーワードの数に応じて自動で配列化できます。

・CountIf関数を使い、行内のA〜E列にキーワードが含まれるかをチェックしています。すべてのキーワードが含まれる場合のみコピーされます。

・新しいシートに抽出する際は、ヘッダー行をコピーしておくと見やすくなります。

まとめ

このVBAコードを利用すれば、ユーザーフォームから入力した任意の数のキーワードでSheet1を検索し、すべてのキーワードが含まれる行だけを新しいシートに抽出できます。キーワードの増減にも柔軟に対応可能で、初心者でも比較的簡単に実装できる方法です。

コメント

タイトルとURLをコピーしました