【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

サブフォルダまで見る(保存無)

Rem 【主な用途】
Rem  指定したフォルダ内のすべてのファイルに関して何かの処理(値を集めるなど)をしたいときに利用します。
Rem  収集した値は出力用シート(outputWs)に書き出すことを想定しています。
Rem    変更の必要がある関数は以下の通りです。それ以外は修正する必要はありません。
Rem    >ProcEachBook ⇒ ブック単位で処理したい場合
Rem    >ProcEachSheet ⇒ シート単位で処理したい場合
Rem    >CheckTargetBook ⇒ 処理対象ブックを絞りたい場合


Rem @note 「ユーザー定義型は定義されていません。」と出てきたら"Microsoft Scriptiong Runtime"を参照設定に追加します。
Rem @note  ツール(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 errorLogCnt As Long
Dim errorWs As Worksheet

' 処理対象ファイル名を書きだすためのシート
Dim outputTargetWs As Worksheet
Dim targetWsCnt As Long

Rem メインの処理
Rem @note Excelからはこの関数を呼びましょう
Sub Main()

    Dim strPath As String                                  ' 選択したフォルダのパス

    With Application.FileDialog(msoFileDialogFolderPicker)  ' フォルダ選択ダイアログ
        If .Show = True Then
            If .SelectedItems(1) = "" Then                ' フォルダが選択されなかった場合
                MsgBox "フォルダを指定してください。"
                Call Done
                Exit Sub
            Else
                strPath = .SelectedItems(1)
            End If
        End If
    End With
    
    Call Init
    
    ' フォルダが選択されたら利用する変数の初期化
    Set outputTargetWs = ThisWorkbook.Worksheets(TARGETWSNAME)
    Set errorWs = ThisWorkbook.Worksheets(ERRORLOGNAME)
    Set outputWs = ThisWorkbook.Worksheets(OUTPUTWSNAME)
    outputCnt = 1
    errorLogCnt = 1
    targetWsCnt = 1
    
    ' システム用シートの値を初期化
    outputTargetWs.Cells.Clear
    errorWs.Range("A2:AA" & errorWs.Cells(Rows.Count, 1).End(xlUp).Row).Clear
    
    'メインの処理を呼び出す
    Call DoInSubFolder(strPath)
    
    Set outputWs = Nothing
    Set errorWs = Nothing
    Set outputTargetWs = Nothing
    
    Call Done
    
    MsgBox "処理が完了しました。"
    
End Sub

Rem 指定したフォルダ内のサブフォルダ内を含むファイルを処理する
Rem @note 「ユーザー定義型は定義されていません。」と出てきたら"Microsoft Scriptiong Runtime"を参照設定に追加します。
Rem @note  ツール(T)>参照設定(R)>「Microsoft Scripting Runtime」
Private Sub DoInSubFolder(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 DoInSubFolder(objFolder.Path)  '//サブフォルダを指定して再帰呼び出し
    Next
    '//フォルダ内のファイルパスを取得(自身以外のExcelブックを対象)
    For Each objFile In fso.GetFolder(folderPath).Files
        With objFile
            If InStr(.Name, "xls") > 0 And InStr(.Name, "~") = 0 Then
                'Excelファイルであれば処理を行う
                On Error Resume Next
                
                Dim targetWbk As Workbook
        
                Workbooks.Open .Path, UpdateLinks:=False
                Set targetWbk = ActiveWorkbook
                
                If Err.Number <> 0 Then
                    'エラーログに出力
                    errorLogCnt = errorLogCnt + 1
                    errorWs.Cells(errorLogCnt, 1).Value = .Path & "は開けませんでした。"
                Else
                    On Error GoTo 0
                    '問題なくファイルを開けたら
                    If CheckTargetBook(.Name) = True Then
                        Call ProcEachBook(targetWbk)
                    End If
                    targetWbk.Close False
                End If
                
                Set targetWbk = Nothing

                outputTargetWs.Cells(targetWsCnt, 1).Value = .Path
                cntFile = cntFile + 1
            End If
        End With
    Next
    Set fso = Nothing
End Sub

Rem それぞれのブックに関する処理
Rem @note DoInSubFolderから呼ばれる
Sub ProcEachBook(wbk As Workbook)
    'それぞれのワークブックの制御
    Dim targetWs As Worksheet

    '_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
    ' ブック単位に処理したい場合はここに処理を書く
    

    '_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
    
    For Each targetWs In wbk.Worksheets
        Call ProcEachSheet(targetWs)
        Set targetWs = Nothing
    Next targetWs
    
End Sub

Rem それぞれのシートに関する処理
Rem @note ProcEachBookから呼ばれる
Sub ProcEachSheet(ws As Worksheet)
    '_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
    'ここに各シートに対する処理を書く
    'endRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    'MsgBox ws.Parent.Name & "::" & ws.Name
    outputWs.Cells(targetWsCnt, 1).Value = ws.Parent.Name & "::" & ws.Name
    targetWsCnt = targetWsCnt + 1
    '_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
End Sub

Rem 対象ブック名を絞り込むための関数
Rem @note 対象ブックを限定する場合記載
Private Function CheckTargetBook(fileName As String)

    CheckTargetBook = True
    
    '#############################
    '例)ブック名に比較を含むとき処理対象とする場合
    '#############################
'   If InStr(fileName, "比較") = 0 Then
'       CheckTargetBook = False
'       Exit Function
'   End If
    '#############################
    
End Function

Rem 初期処理
Private Sub Init()
    With Application
        .Calculation = xlCalculationManual
        '.EnableEvents = False
        .ScreenUpdating = False
    End With
    
    'システム用のシートを作成する
    Call addWorkSheet(ThisWorkbook, TARGETWSNAME)
    Call addWorkSheet(ThisWorkbook, ERRORLOGNAME)
    Call addWorkSheet(ThisWorkbook, OUTPUTWSNAME)
    
End Sub

Rem 終了処理
Private Sub Done()
    With Application
        .Calculation = xlCalculationAutomatic
        '.EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Rem ワークシートが存在することをチェックする関数
Rem @return As Boolean  存在していればTrue
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

Rem ワークシートを追加する関数
Rem @return As Boolean  問題なく追加できればTrue
Private Function addWorkSheet(wbk As Workbook, sheetName As String) As Boolean
    addWorkSheet = False
    
    On Error GoTo wsCreateError
    
    If isExistWorkSheet(wbk, sheetName) = False Then
        Dim ws As Worksheet
        Set ws = wbk.Worksheets.Add
        ws.Name = sheetName
        
        addWorkSheet = True
    End If
    
    Exit Function
wsCreateError:
    addWorkSheet = False
End Function

Rem ワークシートを削除する関数
Rem @return As Boolean  問題なく削除できればTrue
Private Function deleteWorkSheet(wbk As Workbook, sheetName As String) As Boolean
    deleteWorkSheet = 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

Rem MIT License
Rem
Rem Copyright (c) 2020 uedive.net
Rem
Rem Permission is hereby granted, free of charge, to any person obtaining a copy
Rem of this software and associated documentation files (the "Software"), to deal
Rem in the Software without restriction, including without limitation the rights
Rem to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
Rem copies of the Software, and to permit persons to whom the Software is
Rem furnished to do so, subject to the following conditions:
Rem
Rem The above copyright notice and this permission notice shall be included in all
Rem copies or substantial portions of the Software.
Rem
Rem THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
Rem IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
Rem FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
Rem AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
Rem LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
Rem OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
Rem SOFTWARE.

暇な時間にU-NEXT!

今なら無料1ヶ月無料トライアル600円分の有料コンテンツを使えるチャンス!

見放題作品が31日間無料で視聴可能最新作はレンタル配信!

600円分のポイントプレゼント!DVD・ブルーレイよりも先行配信の最新作、放送中ドラマの視聴や最新コミックの購入に使用可能

 

追加料金なく、80誌以上の雑誌が読み放題

 

プログラミング
スポンサーリンク
uediveをフォローする
SEの休日

コメント

  1. […] […]

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