【VBA】フォルダの中にあるファイルを処理する

スポンサーリンク
プログラミング

フォルダ内のファイルをまとめて処理したいときに使えるマクロです。

全てそのままコピペしたら使えます。

処理の流れ

  1. Mainのサブモジュールを実行する
  2. 処理対象のフォルダを選択する
  3. 対象ファイルパスを対象ファイルシートに記載する
  4. 対象ファイルシートに記載されたブックを順に開く
  5. ブックに含まれるシートに対して処理関数を呼ぶ（DoYourMethod）
  6. シートに対する処理を行う（DoEverySheets）
  7. 4に戻る

プログラムの更新

選択したフォルダ内の全てのエクセルファイルに対して処理を行います。

DoEverySheetsでは各シートの処理を行います。引数にはワークシートオブジェクトがあり、読み込んだファイルにあるシートが渡されていきます。

各シートに対してしたい処理をここに記載してください。

例）シート名で分岐を行い、あるシートに対する処理を行わないなど

'ツール(T)＞参照設定(R)＞「Microsoft Scripting Runtime」

Public Const TARGETWSNAME As String = "対象ファイル"
Public Const ERRORLOGNAME As String = "エラーログ"
Public Const OUTPUTWSNAME As String = "出力"

Dim outputCnt As Long
Dim outputWs As Worksheet

Sub Main()

    Dim outputTargetWs As Worksheet
    Dim errorWs As Worksheet
    Dim strPath As String                                   ' 選択したフォルダのパス
    Dim fso As Object                                       ' FileSystemObject
    Dim objFolder As Folder
    Dim objFile As File
    Dim targetWbk As Workbook
    
    
    Dim cntFile As Long
    Dim cntBook As Long
    
    Dim errorLogCnt As Long
    
    'システム用のシートを作成する
    If isExistWorkSheet(ThisWorkbook, TARGETWSNAME) = False Then
        Call addWorkSheet(ThisWorkbook, TARGETWSNAME)
    End If
    
    If isExistWorkSheet(ThisWorkbook, ERRORLOGNAME) = False Then
        Call addWorkSheet(ThisWorkbook, ERRORLOGNAME)
    End If
    
    If isExistWorkSheet(ThisWorkbook, OUTPUTWSNAME) = False Then
        Call addWorkSheet(ThisWorkbook, OUTPUTWSNAME)
    End If
    
    Set outputTargetWs = ThisWorkbook.Worksheets(TARGETWSNAME)
    Set errorWs = ThisWorkbook.Worksheets(ERRORLOGNAME)
    Set outputWs = ThisWorkbook.Worksheets(OUTPUTWSNAME)
    
    outputCnt = 1
    cntFile = 1
    errorLogCnt = errorWs.Cells(Rows.Count, 1).End(xlUp).Row
    errorWs.Range("A2:AA" & errorLogCnt).Clear
    
    With Application.FileDialog(msoFileDialogFolderPicker)  ' フォルダ選択ダイアログ
        If .Show = True Then
            strPath = .SelectedItems(1)
        End If
    End With

    If strPath = "" Then                                    ' フォルダが選択されなかった場合
        MsgBox "フォルダを指定してください。"
        Call Done
        Exit Sub
    End If
    
    Call Init
    
    outputTargetWs.Cells.Clear
    
    Set fso = New FileSystemObject
    
    Set objFolder = fso.GetFolder(strPath)
    
    For Each objFile In objFolder.Files
        With objFile
            If InStr(.Name, "xls") > 0 And InStr(.Name, "~") = 0 Then
                outputTargetWs.Cells(cntFile, 1).Value = .Path
                cntFile = cntFile + 1
            End If
        End With
    Next objFile
    
    For cntBook = 1 To cntFile - 1
        On Error Resume Next
        
        Workbooks.Open outputTargetWs.Cells(cntBook, 1).Value, UpdateLinks:=False
        Set targetWbk = ActiveWorkbook
        
        If Err.Number <> 0 Then
            'エラーログに出力
            errorLogCnt = errorLogCnt + 1
            errorWs.Cells(errorLogCnt, 1).Value = outputTargetWs.Cells(cntBook, 1).Value & "は開けませんでした。"
        Else
            On Error GoTo 0
            '問題なくファイルを開けたら
            Call DoYourMethod(targetWbk, cntBook)
            targetWbk.Close False
        End If
        
        Set targetWbk = Nothing
        
    Next cntBook
    
    Set outputWs = Nothing
    
    Call Done
    
    MsgBox "処理が完了しました。"
    
End Sub

Sub DoYourMethod(wbk As Workbook, cntBook As Long)
    'それぞれのワークブックの制御
    Dim targetWs As Worksheet

    For Each targetWs In wbk.Worksheets
        Call DoEverySheets(targetWs)
        Set targetWs = Nothing
    Next targetWs
    
End Sub

' それぞれのシートに関する処理
Sub DoEverySheets(ws As Worksheet)
    '_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
    'ここに各シートに対する処理を書く
    'endRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    'MsgBox ws.Parent.Name & "::" & ws.Name
    'outputWs.Cells(outputCnt, 1).Value = ws.Parent.Name & "::" & ws.Name
    '_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
End Sub

Sub Init()
    With Application
        .Calculation = xlCalculationManual
        '.EnableEvents = False
        .ScreenUpdating = False
    End With
End Sub

Sub Done()
    With Application
        .Calculation = xlCalculationAutomatic
        '.EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Private Function isExistWorkSheet(wbk As Workbook, sheetName As String) As Boolean
    Dim ws As Worksheet
    isExistWorkSheet = False
    For Each ws In wbk.Worksheets
        If ws.Name = sheetName Then
            isExistWorkSheet = True
            Exit For
        End If
    Next ws
End Function

Private Function addWorkSheet(wbk As Workbook, sheetName As String) As Boolean
    addWorkSheet = False
    
    On Error GoTo wsCreateError
    
    Dim ws As Worksheet
    Set ws = wbk.Worksheets.Add
    ws.Name = sheetName
    
    addWorkSheet = True
    
    Exit Function
wsCreateError:
    addWorkSheet = False
End Function

Private Function deleteWorkSheet(wbk As Workbook, sheetName As String) As Boolean
    Delete Worksheet = False
    
    On Error GoTo wsDeleteError
    
    If isExistWorkSheet(wbk, sheetName) = True Then
        With Application
            .DisplayAlerts = False
            wbk.Worksheets(sheetName).Delete
            .DisplayAlerts = True
        End With
    End If
    
    deleteWorkSheet = True
    Exit Function
    
wsDeleteError:
    deleteWorkSheet = False

End Function

保存ができるバージョン

'ツール(T)＞参照設定(R)＞「Microsoft Scripting Runtime」

Public Const OUTPUTWSNAME As String = "対象ファイル"
Public Const ERRORLOGNAME As String = "エラーログ"

'処理したファイルを保存したい場合　True
Public Const ISSAVEMODE As Boolean = True

'保存フォルダ名　このマクロがあるフォルダにここで設定したフォルダ名のフォルダを作ります
Public Const SAVEFOLDERNAME As String = "処理結果"

Sub Main()

    Dim outputTargetWs As Worksheet
    Dim errorWs As Worksheet
    Dim strPath As String                                   ' 選択したフォルダのパス
    Dim fso As Object                                       ' FileSystemObject
    Dim objFolder As Folder
    Dim objFile As File
    Dim targetWbk As Workbook
    
    
    Dim cntFile As Long
    Dim cntBook As Long
    
    Dim errorLogCnt As Long
    
    'システム用のシートを作成する
    If isExistWorkSheet(ThisWorkbook, OUTPUTWSNAME) = False Then
        Call addWorkSheet(ThisWorkbook, OUTPUTWSNAME)
    End If
    
    If isExistWorkSheet(ThisWorkbook, ERRORLOGNAME) = False Then
        Call addWorkSheet(ThisWorkbook, ERRORLOGNAME)
    End If
    
    Set outputTargetWs = ThisWorkbook.Worksheets(OUTPUTWSNAME)
    Set errorWs = ThisWorkbook.Worksheets(ERRORLOGNAME)
    cntFile = 1
    errorLogCnt = errorWs.Cells(Rows.Count, 1).End(xlUp).Row
    errorWs.Range("A2:AA" & errorLogCnt).Clear
    
    If ISSAVEMODE = True Then
        'ファイルの保存先のパスを作成する
        Dim savePath As String
        savePath = ThisWorkbook.path & "\" & SAVEFOLDERNAME & "\" & Format(Now, "yyyymmddhhnn")
        
        If Dir(savePath, vbDirectory) = "" Then
            Call MakePath(savePath)
        End If
    End If
    
    With Application.FileDialog(msoFileDialogFolderPicker)  ' フォルダ選択ダイアログ
        If .Show = True Then
            strPath = .SelectedItems(1)
        End If
    End With

    If strPath = "" Then                                    ' フォルダが選択されなかった場合
        MsgBox "フォルダを指定してください。"
        Call Done
        Exit Sub
    End If
    
    Call Init
    
    outputTargetWs.Cells.Clear
    
    Set fso = New FileSystemObject
    
    Set objFolder = fso.GetFolder(strPath)
    
    For Each objFile In objFolder.Files
        With objFile
            If InStr(.Name, "xls") > 0 And InStr(.Name, "~") = 0 Then
                outputTargetWs.Cells(cntFile, 1).Value = .path
                cntFile = cntFile + 1
            End If
        End With
    Next objFile
    
    For cntBook = 1 To cntFile - 1
        On Error Resume Next
        
        Workbooks.Open outputTargetWs.Cells(cntBook, 1).Value, UpdateLinks:=False
        Set targetWbk = ActiveWorkbook
        
        If Err.Number <> 0 Then
            'エラーログに出力
            errorLogCnt = errorLogCnt + 1
            errorWs.Cells(errorLogCnt, 1).Value = outputTargetWs.Cells(cntBook, 1).Value & "は開けませんでした。"
        Else
            On Error GoTo 0
            '問題なくファイルを開けたら
            Call DoYourMethod(targetWbk, cntBook)
            Call SaveWorkbook(targetWbk, savePath)
            targetWbk.Close False
        End If
        
        Set targetWbk = Nothing
        
    Next cntBook
    
    Call Done
    
    MsgBox "処理が完了しました。"
    
End Sub

Sub DoYourMethod(wbk As Workbook, cntBook As Long)
    'それぞれのワークブックの制御
    Dim targetWs As Worksheet

    For Each targetWs In wbk.Worksheets
        Call DoEverySheets(targetWs)
        Set targetWs = Nothing
    Next targetWs
    
End Sub

' それぞれのシートに関する処理
Sub DoEverySheets(ws As Worksheet)
    '_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
    'ここに各シートに対する処理を書く
    'MsgBox ws.Parent.Name & "::" & ws.Name
    '_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
End Sub

Sub Init()
    With Application
        .Calculation = xlCalculationManual
        '.EnableEvents = False
        .ScreenUpdating = False
    End With
End Sub

Sub Done()
    With Application
        .Calculation = xlCalculationAutomatic
        '.EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Private Function isExistWorkSheet(wbk As Workbook, sheetName As String) As Boolean
    Dim ws As Worksheet
    isExistWorkSheet = False
    For Each ws In wbk.Worksheets
        If ws.Name = sheetName Then
            isExistWorkSheet = True
            Exit For
        End If
    Next ws
End Function

Private Function addWorkSheet(wbk As Workbook, sheetName As String) As Boolean
    addWorkSheet = False
    
    On Error GoTo wsCreateError
    
    Dim ws As Worksheet
    Set ws = wbk.Worksheets.Add
    ws.Name = sheetName
    
    addWorkSheet = True
    
    Exit Function
wsCreateError:
    addWorkSheet = False
End Function

Private Function deleteWorkSheet(wbk As Workbook, sheetName As String) As Boolean
    Delete Worksheet = False
    
    On Error GoTo wsDeleteError
    
    If isExistWorkSheet(wbk, sheetName) = True Then
        With Application
            .DisplayAlerts = False
            wbk.Worksheets(sheetName).Delete
            .DisplayAlerts = True
        End With
    End If
    
    deleteWorkSheet = True
    Exit Function
    
wsDeleteError:
    deleteWorkSheet = False

End Function

'再帰関数
Sub MakePath(path As String)
    Dim parentFolder As String
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    parentFolder = fso.GetParentFolderName(path)
    If Not fso.FolderExists(parentFolder) Then
        Call MakePath(parentFolder)
    Else
        fso.CreateFolder path
        Exit Sub
    End If
    fso.CreateFolder path
    Set fso = Nothing
End Sub


Sub SaveWorkbook(wbk As Workbook, savePath As String)
    If ISSAVEMODE = True Then
        Application.DisplayAlerts = False
        wbk.SaveAs (savePath & "\" & wbk.Name)
        Application.DisplayAlerts = True
    End If
End Sub

サブフォルダまで見る（保存無）

'ツール(T)＞参照設定(R)＞「Microsoft Scripting Runtime」

Public Const TARGETWSNAME As String = "対象ファイル"
Public Const ERRORLOGNAME As String = "エラーログ"
Public Const OUTPUTWSNAME As String = "出力"

Dim outputCnt As Long
Dim outputWs As Worksheet
Dim inputTargetWs As Worksheet

Dim cntFile As Long

Sub Main()

    Dim errorWs As Worksheet
    Dim strPath As String                                   ' 選択したフォルダのパス
    Dim fso As Object                                       ' FileSystemObject
    Dim objFolder As Folder
    Dim objFile As File
    Dim targetWbk As Workbook
    
    Dim cntBook As Long
    
    Dim errorLogCnt As Long
    
    'システム用のシートを作成する
    If isExistWorkSheet(ThisWorkbook, TARGETWSNAME) = False Then
        Call addWorkSheet(ThisWorkbook, TARGETWSNAME)
    End If
    
    If isExistWorkSheet(ThisWorkbook, ERRORLOGNAME) = False Then
        Call addWorkSheet(ThisWorkbook, ERRORLOGNAME)
    End If
    
    If isExistWorkSheet(ThisWorkbook, OUTPUTWSNAME) = False Then
        Call addWorkSheet(ThisWorkbook, OUTPUTWSNAME)
    End If
    
    Set inputTargetWs = ThisWorkbook.Worksheets(TARGETWSNAME)
    Set errorWs = ThisWorkbook.Worksheets(ERRORLOGNAME)
    Set outputWs = ThisWorkbook.Worksheets(OUTPUTWSNAME)
    
    outputCnt = 1
    cntFile = 1
    errorLogCnt = errorWs.Cells(Rows.Count, 1).End(xlUp).Row
    errorWs.Range("A2:AA" & errorLogCnt).Clear
    
    With Application.FileDialog(msoFileDialogFolderPicker)  ' フォルダ選択ダイアログ
        If .Show = True Then
            strPath = .SelectedItems(1)
        End If
    End With

    If strPath = "" Then                                    ' フォルダが選択されなかった場合
        MsgBox "フォルダを指定してください。"
        Call Done
        Exit Sub
    End If
    
    Call Init
    
    inputTargetWs.Cells.Clear
    
    Call getFile(strPath)
    
    
    For cntBook = 1 To cntFile - 1
        On Error Resume Next

        Workbooks.Open inputTargetWs.Cells(cntBook, 1).Value, UpdateLinks:=False
        Set targetWbk = ActiveWorkbook

        If Err.Number <> 0 Then
            'エラーログに出力
            errorLogCnt = errorLogCnt + 1
            errorWs.Cells(errorLogCnt, 1).Value = inputTargetWs.Cells(cntBook, 1).Value & "は開けませんでした。"
        Else
            On Error GoTo 0
            '問題なくファイルを開けたら
            Call DoYourMethod(targetWbk, cntBook)
            targetWbk.Close False
        End If

        Set targetWbk = Nothing

    Next cntBook
    
    Set outputWs = Nothing
    Set inputTargetWs = Nothing
    
    Call Done
    
    MsgBox "処理が完了しました。"
    
End Sub

'対象ブック名を絞り込むための関数
'サブフォルダからファイル名を取得する際に呼ばれる。
'TODO 対象ファイルを限定する場合記載
Private Function checkTargetBook(fileName As String)

    checkTargetBook = True
    
    '#############################
    '例）比較を含むファイルを対象にする
    '#############################
'    If InStr(fileName, "比較") = 0 Then
'        checkTargetBook = False
'        Exit Function
'    End If
    '#############################
    
End Function


'//サブフォルダ含めてすべてのファイルを操作
Private Sub getFile(folderPath As String)
    Dim fso As FileSystemObject
    Set fso = New FileSystemObject
    Dim objFolder As Folder
    Dim objFile As File
    '//すべてのフォルダを操作
    For Each objFolder In fso.GetFolder(folderPath).SubFolders
        Call getFile(objFolder.Path)  '//サブフォルダを指定して再帰呼び出し
    Next
    '//フォルダ内のファイルパスを取得(自身以外のExcelブックを対象)
    For Each objFile In fso.GetFolder(folderPath).Files
        With objFile
            If InStr(.Name, "xls") > 0 And InStr(.Name, "~") = 0 Then
                If checkTargetBook(.Name) = True Then
                    inputTargetWs.Cells(cntFile, 1).Value = .Path
                    cntFile = cntFile + 1
                End If
            End If
        End With
    Next
    Set fso = Nothing
End Sub

Sub DoYourMethod(wbk As Workbook, cntBook As Long)
    'それぞれのワークブックの制御
    Dim targetWs As Worksheet

    For Each targetWs In wbk.Worksheets
        Call DoEverySheets(targetWs)
        Set targetWs = Nothing
    Next targetWs
    
End Sub

' それぞれのシートに関する処理
Sub DoEverySheets(ws As Worksheet)
    '_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
    'ここに各シートに対する処理を書く
    'endRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    'MsgBox ws.Parent.Name & "::" & ws.Name
    'outputWs.Cells(outputCnt, 1).Value = ws.Parent.Name & "::" & ws.Name
    '_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
End Sub

Sub Init()
    With Application
        .Calculation = xlCalculationManual
        '.EnableEvents = False
        .ScreenUpdating = False
    End With
End Sub

Sub Done()
    With Application
        .Calculation = xlCalculationAutomatic
        '.EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Private Function isExistWorkSheet(wbk As Workbook, sheetName As String) As Boolean
    Dim ws As Worksheet
    isExistWorkSheet = False
    For Each ws In wbk.Worksheets
        If ws.Name = sheetName Then
            isExistWorkSheet = True
            Exit For
        End If
    Next ws
End Function

Private Function addWorkSheet(wbk As Workbook, sheetName As String) As Boolean
    addWorkSheet = False
    
    On Error GoTo wsCreateError
    
    Dim ws As Worksheet
    Set ws = wbk.Worksheets.Add
    ws.Name = sheetName
    
    addWorkSheet = True
    
    Exit Function
wsCreateError:
    addWorkSheet = False
End Function

Private Function deleteWorkSheet(wbk As Workbook, sheetName As String) As Boolean
    Delete Worksheet = False
    
    On Error GoTo wsDeleteError
    
    If isExistWorkSheet(wbk, sheetName) = True Then
        With Application
            .DisplayAlerts = False
            wbk.Worksheets(sheetName).Delete
            .DisplayAlerts = True
        End With
    End If
    
    deleteWorkSheet = True
    Exit Function
    
wsDeleteError:
    deleteWorkSheet = False

End Function
スポンサーリンク

コメント

  1. 【コピペOK】ExcelVBA 処理サンプル | SEの休日 より:
    2020/09/26 8:10 PM

    […] […]

    返信
タイトルとURLをコピーしました