使い方
- 結果貼り付け用にシート名 「結果」 を作る
- VBAに上のコードを貼る
ExtractRowsContainingABC_InColumnBを実行- フォルダを選ぶ → 抽出結果が「結果」シートに出る
Option Explicit
Public Sub ExtractRowsContainingABC_InColumnB()
Dim targetFolder As String
Dim outWs As Worksheet
Dim outRow As Long
Dim fso As Object
Dim folderObj As Object
Dim fileObj As Object
Dim wb As Workbook
Dim ws As Worksheet
Dim lastRow As Long
Dim lastCol As Long
Dim r As Long
Dim bText As String
Dim hit As Boolean
'=== 設定 ===
'結果貼り付け先シート名
Set outWs = ThisWorkbook.Worksheets("結果")
'開始行（1行目は見出しにしたいなら 2 に）
outRow = 2
'フォルダ選択（ダイアログ）
targetFolder = PickFolder()
If Len(targetFolder) = 0 Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
'出力シートを初期化（必要に応じてコメントアウト）
outWs.Cells.Clear
outWs.Cells(1, 1).Value = "ファイル名"
outWs.Cells(1, 2).Value = "抽出行（B列ヒット行の全列）"
Set fso = CreateObject("Scripting.FileSystemObject")
Set folderObj = fso.GetFolder(targetFolder)
'=== フォルダ内のファイルを走査 ===
For Each fileObj In folderObj.Files
If IsExcelFile(fileObj.Name) Then
On Error Resume Next
Set wb = Workbooks.Open(Filename:=fileObj.Path, ReadOnly:=True)
If Err.Number <> 0 Then
Err.Clear
On Error GoTo 0
GoTo NextFile
End If
On Error GoTo 0
'各シートを対象（特定シートだけならここを調整）
For Each ws In wb.Worksheets
'空シート対策
If Application.WorksheetFunction.CountA(ws.Cells) = 0 Then
GoTo NextSheet
End If
lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
lastCol = GetLastUsedCol(ws)
'B列を走査（1行目がヘッダなら 2 からに変えてOK）
For r = 1 To lastRow
bText = CStr(ws.Cells(r, "B").Value2) '改行含んでもOK
hit = (InStr(1, bText, "ABC", vbTextCompare) > 0)
If hit Then
'A列にファイル名（必要ならシート名も付ける）
outWs.Cells(outRow, 1).Value = wb.Name & " / " & ws.Name
'B列以降に「その行の全列」を貼り付け
'※値として貼る（書式は不要ならこれが安全）
outWs.Cells(outRow, 2).Resize(1, lastCol).Value = ws.Cells(r, 1).Resize(1, lastCol).Value
outRow = outRow + 1
End If
Next r
NextSheet:
Next ws
wb.Close SaveChanges:=False
End If
NextFile:
DoEvents
Next fileObj
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
MsgBox "完了: " & (outRow - 2) & " 行 抽出しました。", vbInformation
End Sub
'--- フォルダ選択ダイアログ ---
Private Function PickFolder() As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "対象フォルダを選択してください"
.AllowMultiSelect = False
If .Show <> -1 Then
PickFolder = ""
Else
PickFolder = .SelectedItems(1)
End If
End With
End Function
'--- Excelファイル判定 ---
Private Function IsExcelFile(ByVal fileName As String) As Boolean
Dim ext As String
ext = LCase$(Mid$(fileName, InStrRev(fileName, ".") + 1))
IsExcelFile = (ext = "xlsx" Or ext = "xlsm" Or ext = "xls")
End Function
'--- シートの最終使用列（UsedRangeベース） ---
Private Function GetLastUsedCol(ByVal ws As Worksheet) As Long
On Error GoTo EH
If ws.UsedRange Is Nothing Then
GetLastUsedCol = 1
Else
GetLastUsedCol = ws.UsedRange.Columns(ws.UsedRange.Columns.Count).Column
If GetLastUsedCol < 1 Then GetLastUsedCol = 1
End If
Exit Function
EH:
GetLastUsedCol = 1
End Function