【EXCEL VBA】検索キーを中心に上下左右の値を取得するサンプル（一括処理）

前回のソースコードをさらに発展させ、指定フォルダ内のExcelファイル群から検索キーを中心に上下左右のデータを一括で抽出するExcel VBAマクロのサンプルコードです。

本記事で紹介するコードは、旧外部配布ファイルが失効しているため、記事内の仕様を基に現代の環境で再構成した実装例です。

この記事でできること

指定したフォルダ（例: C:\test）に含まれる複数のExcelファイルに対し、再帰的にファイル探索を行い、特定のシートから「ラベル」文字列を検索してその周辺（上下左右）のセル値やファイル情報を集約シートへ一括抽出します。また、大量ファイルの処理を想定し、処理の中断・再開機能を備えています。

想定環境・前提条件

• Microsoft Excel (Windows版)
• VBAエディタで「Microsoft Scripting Runtime」への参照設定が必要です（FileSystemObject使用のため）。

サンプルコード

【Sheet1（集約用シート）のコード】

Option Explicit

'処理状態
Enum JobExecStatus
    NON = 0 '未実行
    DOING
    FIN
End Enum
Public m_JobExcStat As JobExecStatus

Sub SEARCH_FOLDER(ByVal path As String, ByRef Row As Long)
    Dim objFSO As FileSystemObject
    Set objFSO = New FileSystemObject
    
    Call SEARCH_SUB_FOLDER(objFSO.GetFolder(path), Row)
    Set objFSO = Nothing
End Sub

Private Sub SEARCH_SUB_FOLDER(ByVal objPATH As Folder, ByRef Row As Long)
    Dim objPATH2 As Folder
    On Error Resume Next

    Dim objFILE As File
    For Each objFILE In objPATH.Files
        If m_JobExcStat <> DOING Then Exit For
        
        With objFILE
            GetRange(Me, Row, 出力列.Index).Value = CStr(Row - 出力行.ヘッダ)
            GetRange(Me, Row, 出力列.Status).Value = GetStatusString(JobStatus.NON)
            GetRange(Me, Row, 出力列.ファイル名).Value = .Path
            GetRange(Me, Row, 出力列.ファイル作成日).Value = .DateCreated
            GetRange(Me, Row, 出力列.ファイルアクセス日).Value = .DateLastAccessed
            GetRange(Me, Row, 出力列.ファイル更新日).Value = .DateLastModified
        End With
        Row = Row + 1
        DoEvents
    Next objFILE
    Set objPATH = Nothing
End Sub

Sub MakeHedder()
    On Error Resume Next
    Range(Columns(出力列.Index), Columns(出力列.ファイルアクセス日)).ClearComments
    Call GetRange(Me, 出力行.ヘッダ, 出力列.Index).AddComment(GetHeaderString(出力列.Index))
    Call GetRange(Me, 出力行.ヘッダ, 出力列.Status).AddComment(GetHeaderString(出力列.Status))
    Call GetRange(Me, 出力行.ヘッダ, 出力列.エラー詳細).AddComment(GetHeaderString(出力列.エラー詳細))
    Call GetRange(Me, 出力行.ヘッダ, 出力列.テスト結果).AddComment(GetHeaderString(出力列.テスト結果))
    
    Dim r As Range
    For Each r In Range(Columns(出力列.Index), Columns(出力列.ファイルアクセス日))
        r.Comment.Visible = True
    Next r
End Sub

Private Sub CommandButton1_Click()
    m_JobExcStat = DOING
    Range(Columns(出力列.Index), Columns(出力列.ファイルアクセス日)).ClearContents
    Call MakeHedder
    Dim LastRow As Long
    LastRow = 出力行.データ
    Call SEARCH_FOLDER("C:\test", LastRow)
    m_JobExcStat = FIN
End Sub

Private Sub CommandButton2_Click()
    On Error GoTo EXCEPTION
    Dim LastRow As Long
    LastRow = 出力行.データ
    GetRange(Me, LastRow, 出力列.ワークシート名).Value = 1
    
    m_JobExcStat = DOING
    Dim tmp As Range
    For Each tmp In Me.Range("D4:D2000")
        If m_JobExcStat <> DOING Then Exit For
        If ((tmp.Value <> "") And (tmp.Value <> GetStatusString(JobStatus.OK))) Then
            Call GetData(CStr(GetRange(Me, LastRow, 出力列.ファイル名).Value), LastRow)
            LastRow = LastRow + 1
        End If
        DoEvents
    Next tmp
    Exit Sub
EXCEPTION:
    GetRange(Me, LastRow, 出力列.Status).Value = GetStatusString(JobStatus.NG)
    Resume Next
End Sub

Private Sub CommandButton3_Click()
    m_JobExcStat = FIN
End Sub

Function GetData(ByVal path As String, ByVal Row As Long) As Boolean
On Error GoTo EXCEPTION
    GetData = False
    Dim srcwb As Workbook
    Dim dstwb As Workbook
    Dim srcws As Worksheet
    
    Set dstwb = ThisWorkbook
    Set srcwb = Workbooks.Open(path, ReadOnly:=True)
    Set srcws = GetWorkSheet(srcwb, "Sheet")
    
    GetRange(dstwb.ActiveSheet, Row, 出力列.ワークシート名).Value = srcws.Name
    Dim val As String
    val = GetTargetParameter(srcws.Range("A1:E30"), "ラベル", 1, 0)
    GetRange(dstwb.ActiveSheet, Row, 出力列.テスト結果).Value = val
    
    GetRange(Me, Row, 出力列.Status).Value = GetStatusString(JobStatus.OK)
    GetData = True
    srcwb.Close SaveChanges:=False
    Exit Function
EXCEPTION:
    GetRange(Me, Row, 出力列.Status).Value = GetStatusString(JobStatus.NG)
    srcwb.Close SaveChanges:=False
End Function

Function GetTargetParameter(ByRef searchArea As Range, ByVal targetLabel As String, ByVal RowOffset As Integer, ByVal ColumnOffset As Integer) As String
    Dim r As Range
    GetTargetParameter = "0"
    For Each r In searchArea
        If r.Value = targetLabel Then
            Call setOffsetRow(r, RowOffset)
            Call setOffsetColumn(r, ColumnOffset)
            GetTargetParameter = CStr(r.Value)
            Exit For
        End If
    Next r
End Function

Sub setOffsetRow(ByRef r As Range, ByVal RowOffset As Integer)
    Dim i As Integer
    If RowOffset <> 0 Then
        For i = 1 To Abs(RowOffset)
            Set r = r.Offset(Sgn(RowOffset), 0)
        Next i
    End If
End Sub

Sub setOffsetColumn(ByRef r As Range, ByVal ColumnOffset As Integer)
    Dim i As Integer
    If ColumnOffset <> 0 Then
        For i = 1 To Abs(ColumnOffset)
            Set r = r.Offset(0, Sgn(ColumnOffset))
        Next i
    End If
End Sub

Public Function GetRange(ByRef ws As Worksheet, ByVal Row As Long, ByVal column As Long) As Range
    Set GetRange = ws.Cells(Row, column)
End Function

【Module1のコード】

Option Explicit

Enum 出力列
    Index = 3
    Status
    テスト結果
    ファイル名
    エラー詳細
    ファイル作成日
    ファイル更新日
    ファイルアクセス日
    ワークシート名
End Enum

Enum JobStatus
    NON = 0
    NG
    OK
End Enum

Enum 出力行
    ヘッダ = 3
    データ = 4
End Enum

Function GetHeaderString(ByVal column As 出力列) As String
    Dim Table() As String
    Table = Split("インデックス,ステータス,ファイル名,テスト結果,エラー詳細,ファイル作成日,ファイル更新日,ファイルアクセス日,ワークシート名", ",")
    GetHeaderString = Table(column - 出力列.Index)
End Function

Function GetStatusString(ByVal stat As JobStatus) As String
    Dim Table() As String
    Table = Split("未抽出,抽出失敗,抽出成功", ",")
    GetStatusString = Table(stat)
End Function

Function GetWorkSheet(ByRef wb As Workbook, searchStr As String) As Worksheet
    Dim wksh As Worksheet
    For Each wksh In wb.Worksheets
        If InStr(1, wksh.Name, searchStr, vbBinaryCompare) > 0 Then
            Set GetWorkSheet = wksh
            Exit For
        End If
    Next wksh
End Function

使い方と注意事項

• 実行前に対象となるフォルダパス（例: C:\test）が存在するか確認してください。
• 外部ブックを開く処理が含まれるため、マクロ実行時はセキュリティ設定やファイルの読み取り権限に注意してください。