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

「extract1.zip」をダウンロード

前回のソースをさらに発展させた。

あるフォルダ内のexcelファイルから、検索キーを中心にデータを一括で抽出するマクロ

サンプルでは、"C:\test"にあるファイル一覧を抽出し、そのファイル毎に"ラベル"から下に１つ下がった所にある値を抽出する。

工夫している点は、大量のファイル処理を想定したため、処理の中断と再実行の実装。

ちょっとしたサンプルを作る予定がなかなかのコード量になってしまった。

【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
    Dim strPATHNAME As String
    Set objFSO = New FileSystemObject
   
    Call SEARCH_SUB_FOLDER(objFSO.GetFolder(path), Row)
    ‘ 参照OBJECTを破棄
    Set objFSO = Nothing
End Sub

‘*******************************************************************************
‘   フォルダ単位のサブ処理(再帰動作,引数はFile-Object,行)
‘*******************************************************************************
Private Sub SEARCH_SUB_FOLDER(ByVal objPATH As Folder, _
                              ByRef Row As Long)
    Dim objPATH2 As Folder

On Error Resume Next

‘    ‘ ■先ずサブフォルダを探索するループ処理
‘    For Each objPATH2 In objPATH.SubFolders
‘        ‘ フォルダ単位のサブ処理(再帰呼び出し)
‘        Call SEARCH_SUB_FOLDER(objPATH2, Row)
‘    Next objPATH2

    Dim objFILE As File
    ‘ ■本フォルダの各ファイルをシート上に表示するループ処理
    For Each objFILE In objPATH.Files
        If m_JobExcStat <> DOING Then ‘実行中以外となった場合処理を抜ける
            Exit For
        End If
       
        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
    ‘ 参照OBJECTを破棄
    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(出力列.テスト結果))
    Call GetRange(Me, 出力行.ヘッダ, 出力列.ファイルアクセス日).AddComment(GetHeaderString(出力列.ファイルアクセス日))
    Call GetRange(Me, 出力行.ヘッダ, 出力列.ファイル更新日).AddComment(GetHeaderString(出力列.ファイル更新日))
    Call GetRange(Me, 出力行.ヘッダ, 出力列.ファイル作成日).AddComment(GetHeaderString(出力列.ファイル作成日))
    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
    Dim statStr As String
    statStr = GetStatusString(JobStatus.OK)
    For Each tmp In Me.Range("D4:D2000")  ‘パラメータ化でサイズ変更可能にする
        If m_JobExcStat <> DOING Then ‘実行中以外となった場合処理を抜ける
            Exit For
        End If
        ‘未処理、ＮＧの状態の時処理を実行する。
        If ((tmp.Value <> "") And (tmp.Value <> GetStatusString(JobStatus.OK))) Then
            Call GetData(GetRange(Me, LastRow, 出力列.ファイル名), LastRow)
            LastRow = LastRow + 1
        End If
        DoEvents ‘件数が多い場合を考え、１処理毎に制御をwindowsへ返す
    Next tmp
    Exit Sub
    m_JobExcStat = FIN
EXCEPTION:
    GetRange(Me, LastRow, 出力列.Status).Value = GetStatusString(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
    Dim dstws As Worksheet
       
    Set dstwb = ThisWorkbook
    Set dstws = dstwb.ActiveSheet
   
    Set srcwb = Workbooks.Open(path)
    Set srcws = GetWorkSheet(srcwb, "Sheet")
   
    GetRange(dstws, Row, 出力列.ワークシート名).Value = srcws.Name
    Dim val As String
    val = GetTargetParameter(srcws.Range("A1:E30"), "ラベル", 1, 0) ‘ここはパラメータ化する。
    GetRange(dstws, Row, 出力列.テスト結果).Value = val
   
    GetRange(Me, Row, 出力列.Status).Value = GetStatusString(OK)
    GetData = True
    srcwb.Close
   
    Exit Function
EXCEPTION:
    GetRange(Me, Row, 出力列.Status).Value = GetStatusString(NG)
    GetRange(Me, Row, 出力列.エラー詳細).Value = GetRange(Me, Row, 出力列.エラー詳細).Value & Err.Number & Err.Description
    srcwb.Close
End Function

‘ある指定の範囲からのラベルをキーにデータを取得する。
Function GetTargetParameter(ByRef serchArea As Range, ByVal targetLabel As String, ByVal RowOffset As Integer, ByVal ColumnOffset As Integer) As String
    Dim r As Range
    Dim r2 As Range
   
    GetTargetParameter = 0
    For Each r In serchArea
        If r.Value = targetLabel Then
            ‘オフセット回、セルのアドレスを再設定（起点をずらす）
             Call setOffsetRow(r, RowOffset)
             Call setOffsetColumn(r, ColumnOffset)
             Debug.Print "address=" & r.Address & " value=" & r.Value
             GetTargetParameter = 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
        Exit Sub
    ElseIf RowOffset < 0 Then
        For i = 1 To Abs(RowOffset)
            Set r = r.Offset(-1, 0)
        Next i
    Else
        For i = 1 To RowOffset
            Set r = r.Offset(1, 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
        Exit Sub
    ElseIf ColumnOffset < 0 Then
        For i = 1 To Abs(ColumnOffset)
            Set r = r.Offset(0, -1)
        Next i
    Else
        For i = 1 To ColumnOffset
            Set r = r.Offset(0, 1)
        Next i
    End If
End Sub

‘個別実行
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    On Error Resume Next ‘処理の成否は問わない。
   
    If ((Target.column = 出力列.Status) And (Target.Value <> "") And (Target.Value <> GetStatusString(JobStatus.OK))) Then
        Dim path As String
        path = GetRange(Me, Target.Row, 出力列.ファイル名).Value
        Call GetData(path, Target.Row)
    End If

End Sub

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

【Module1】の処理

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 HasString(wksh.Name, searchStr) Then
            Set GetWorkSheet = wksh
            Exit For
        End If
    Next wksh
End Function

Function HasString(ByVal targetStr As String, ByVal searchStr As String) As Boolean
        HasString = False
        If (targetStr <> "") And (searchStr <> "") Then
            Dim ret As Integer
            ret = InStr(1, targetStr, searchStr, vbBinaryCompare)
            If ret <> 0 Then
                HasString = True
            End If
        End If
End Function