Excelのデータ処理では、特定の文字列を含む行を別シートに抽出したいときがあります。手動でこの作業を行うのは手間がかかりますが、VBAマクロを使えば簡単に自動化ができます。この記事では、特定の文字列を含む行を抽出して別シートにコピーするマクロの作り方を解説します。
ボールペンでヒットした行を新しいシートに行コピーする

コピー元シートのB列のボールペンを検索し、ヒットした行を抽出データシートに行ごとコピーをするというVBAマクロです。
Sub 特定の文字列を含む行を抽出()
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim lastRow As Long
Dim i As Long
Dim targetRow As Long
Dim cellValue As String
' シートの設定
Set sourceSheet = ThisWorkbook.Sheets("コピー元")
On Error Resume Next
Application.DisplayAlerts = False
Sheets("抽出データ").Delete ' 既に存在する場合は削除
Application.DisplayAlerts = True
On Error GoTo 0
Set targetSheet = ThisWorkbook.Sheets.Add
targetSheet.Name = "抽出データ"
' 元シートの最終行を取得
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "B").End(xlUp).Row
targetRow = 1
' ヘッダーをコピー
sourceSheet.Rows(1).Copy Destination:=targetSheet.Rows(1)
targetRow = targetRow + 1
' 列Bのデータをループ(2行目から検索)
For i = 2 To lastRow
cellValue = CStr(sourceSheet.Cells(i, 2).Value) ' 列Bを文字列として扱う
cellValue = Trim(Replace(cellValue, " ", "")) ' 全角スペース削除(全角対応)
' 完全一致
If cellValue = "ボールペン" Then
sourceSheet.Rows(i).Copy Destination:=targetSheet.Rows(targetRow)
targetRow = targetRow + 1
End If
Next i
' コピーしたデータの列幅を調整
targetSheet.Columns.AutoFit
MsgBox "完全一致でデータの抽出が完了しました。", vbInformation, "完了"
End Sub
このマクロを使用するために、シート名を変更します。
Set sourceSheet = ThisWorkbook.Sheets("コピー元")
上記の箇所が特定文字のボールペンを検索している元シートになります。ご自身のエクセルに合わせ、”コピー元”の文言を修正する必要があります。
' 元シートの最終行を取得
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "B").End(xlUp).Row
上記のRows.Count, “B” このBの箇所を特定文字を検索したい列にします。今回は商品名のボールペンを検索文字として利用したいため、B列になります。
' 完全一致
If cellValue = "ボールペン" Then
上記の箇所で特定文字の設定をしています。今回は、B列のボールペンに該当した行を抽出したいため、”ボールペン”と入力してあります。
targetSheet.Name = "抽出データ"
上記の”抽出データ”の箇所を抽出した行を反映したいシート名に修正をします。
Sheets("抽出データ").Delete ' 既に存在する場合は削除
同様に上記も抽出した行を反映したいシート名に修正をします。

マクロ実行後は、コピー元シートで、ボールペンとヒットした行を、抽出シートに行ごとコピーするということが簡単に出来ます。
Excelセル入力で検索文字・列に対応させる
次に、先ほどのVBAマクロを覚えたものの、毎回検索したい文字が変わる。そんなケースを想定し、検索文字、検索列というセルを実装します。

Sub 特定の文字列を含む行を抽出()
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim lastRow As Long
Dim i As Long
Dim targetRow As Long
Dim cellValue As String
Dim searchColumn As String
Dim searchString As String
Dim colNumber As Long
' シートの設定
Set sourceSheet = ThisWorkbook.Sheets("コピー元")
' 検索条件をE7・E8セルから取得
searchColumn = sourceSheet.Range("E7").Value ' 検索列(例: "B")
searchString = sourceSheet.Range("E8").Value ' 検索文字(例: "ボールペン")
colNumber = sourceSheet.Range(searchColumn & "1").Column ' 列番号に変換
' 抽出シートを再作成
On Error Resume Next
Application.DisplayAlerts = False
Sheets("抽出データ").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set targetSheet = ThisWorkbook.Sheets.Add
targetSheet.Name = "抽出データ"
' 元シートの最終行を取得(検索列の最終行)
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, colNumber).End(xlUp).Row
targetRow = 1
' ヘッダーをコピー
sourceSheet.Rows(1).Copy Destination:=targetSheet.Rows(1)
targetRow = targetRow + 1
' データをループ(2行目から検索)
For i = 2 To lastRow
cellValue = CStr(sourceSheet.Cells(i, colNumber).Value) ' 検索列の値
cellValue = Trim(Replace(cellValue, " ", "")) ' 全角スペース削除
' 完全一致判定
If cellValue = searchString Then
sourceSheet.Rows(i).Copy Destination:=targetSheet.Rows(targetRow)
targetRow = targetRow + 1
End If
Next i
' 列幅を自動調整
targetSheet.Columns.AutoFit
MsgBox "完全一致で [" & searchColumn & "] 列から '" & searchString & "' を抽出しました。", vbInformation, "完了"
End Sub
汎用性をもたらすためには、コピー元シートのE7セル、E8セルを検索用の検索列と検索文字というような欄を設けます。
' 検索条件をE7・E8セルから取得
searchColumn = sourceSheet.Range("E7").Value ' 検索列(例: "B")
searchString = sourceSheet.Range("E8").Value ' 検索文字(例: "ボールペン")
上記のようにVBAコードを書き換えることで、エクセルE7セルに入力した列、エクセルE8セルに入力した文字を検索対象とすることが可能です。
ダイアログを使用し検索文字や列を抽出する
先ほどは、Excelのセルを使用し、検索したい文字や列を指定しましたが、今度は、さらに汎用性がきくように、ダイアログで検索したい文字や列を指定してみます。
Sub 特定の文字列を含む行を抽出_ダイアログ()
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim lastRow As Long
Dim i As Long
Dim targetRow As Long
Dim cellValue As String
Dim searchColumn As String
Dim searchString As String
Dim colNumber As Long
' シートの設定
Set sourceSheet = ThisWorkbook.Sheets("コピー元")
' ダイアログで検索条件を取得
searchColumn = InputBox("検索対象列を入力してください(例: A, B, C...)", "検索列指定", "B")
If searchColumn = "" Then Exit Sub ' キャンセル時は終了
searchString = InputBox("検索文字列を入力してください", "検索文字指定", "ボールペン")
If searchString = "" Then Exit Sub ' キャンセル時は終了
colNumber = sourceSheet.Range(searchColumn & "1").Column ' 列番号に変換
' 抽出シートを再作成
On Error Resume Next
Application.DisplayAlerts = False
Sheets("抽出データ").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set targetSheet = ThisWorkbook.Sheets.Add
targetSheet.Name = "抽出データ"
' 元シートの最終行を取得(検索列の最終行)
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, colNumber).End(xlUp).Row
targetRow = 1
' ヘッダーをコピー
sourceSheet.Rows(1).Copy Destination:=targetSheet.Rows(1)
targetRow = targetRow + 1
' データをループ(2行目から検索)
For i = 2 To lastRow
cellValue = CStr(sourceSheet.Cells(i, colNumber).Value)
cellValue = Trim(Replace(cellValue, " ", "")) ' 全角スペース削除
' 完全一致
If cellValue = searchString Then
sourceSheet.Rows(i).Copy Destination:=targetSheet.Rows(targetRow)
targetRow = targetRow + 1
End If
Next i
' 列幅を自動調整
targetSheet.Columns.AutoFit
MsgBox "完全一致で [" & searchColumn & "] 列から '" & searchString & "' を抽出しました。", vbInformation, "完了"
End Sub

VBAマクロを実行すると、ダイアログで検索列を指定します。今回は商品名でB列を指定したいため、Bと入力します。

次に検索文字列として、ボールペンに該当する1行を抽出したいため、ボールペンと入力します。

実行結果として、抽出データシートにボールペンに該当した1行が反映されます。
まとめ
いかがでしたでしょうか。この記事では、Excelで特定の文字列を含む行を自動的に抽出して別シートにコピーするマクロのご紹介。また、汎用性をもたらすために、検索列、検索文字という欄をエクセル表に設け、毎回変わる検索文字に対応する方法、そして、検索列と検索文字の欄をエクセル表に作るのではなく、ダイアログとして、マクロ実行時にウィンドウで検索列や検索文字を決める方法の3つをご紹介しました。


コメント