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

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

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

処理の流れ
プログラムの更新
保存ができるバージョン

処理の流れ

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

プログラムの更新

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

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

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

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


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

Public Const OUTPUTWSNAME As String = "対象ファイル"
Public Const ERRORLOGNAME 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
    
    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
    
    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

保存ができるバージョン

'ツール(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