vba

複数Excelから特定文字を含む行を抽出

Posted on by keeper

使い方

  1. 結果貼り付け用にシート名 「結果」 を作る
  2. VBAに上のコードを貼る
  3. ExtractRowsContainingABC_InColumnB を実行
  4. フォルダを選ぶ → 抽出結果が「結果」シートに出る
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

keeper