Excel VBA 指定フォルダ内のサブフォルダを全て取得してファイルを読み込む

ファイル/フォルダ操作

今回は指定したフォルダ内のサブフォルダを全て取得して、サブフォルダ内のファイルをすべて1つのファイルに読み込む方法をご説明します。

年や月、日別に分けられて管理されているデータを1つのファイルにまとめることで、集計が非常に楽になります。

別ファイルのシートのデータを転記するのではなく、シートをそのままコピーします。

読み込むことで、他のファイルを集計する際などに、別ファイルを操作するよりもVBAが書かれたファイルのみで操作が出来るため、処理のコードが簡素になります。

サブフォルダ内のファイルを読み込むには、直下のフォルダを指定して、それからサブフォルダを取得します。

順番に説明します。

その他の方法でファイルを読み込む方法は下記記事をご覧ください。

1.メインフォルダの指定方法

サブフォルダの取得方法については、直下のメインフォルダを指定してサブフォルダを取得するという処理となります。

ダイアログで指定する方法や、直接コードで指定する方法などフォルダの指定方法がいくつかありますので、順番に説明します。

コード内で直接フォルダを指定する

フォルダを指定するには「CreateObject(“WScript.Shell”)で指定します。

本来カレントフォルダの指定は「ChDirプロパティ」を使用しますが、共有ネットワーク上のフォルダに対応できるように「CreateObject(“WScript.Shell”)」を使用しています。

Sub Sample1()

With CreateObject("WScript.Shell")
    
    .CurrentDirectory = "C:\Sampleフォルダ\"
    
End With

End Sub

ダイアログボックスで指定する

ダイアログボックスで取得する場合は「Application.FileDialog(msoFileDialogFolderPicker ).Showと書きます。 

指定されたフォルダ名は「SelectedItems(1)」で取得します。

指定したフォルダが存在しないとエラーとなるため、「.Show <> 0 」で指定されたフォルダ名が存在するか判定して、存在する場合は取得します。

Sub Sample2()

Dim myFolder As Variant

With Application.FileDialog(msoFileDialogFolderPicker)

    If .Show <> 0 Then
        myFolder = .SelectedItems(1)
    End If

End With

MsgBox myFolder

End Sub

2.指定フォルダ内のサブフォルダをすべて取得する

フォルダの指定ができましたので、次に指定したフォルダ内のサブフォルダを取得する方法です。

フォルダの一覧を取得出来てしまえば、各フォルダ内のファイルを開く事も可能です。

フォルダ内のサブフォルダを取得する方法は「FileSystemObject」を使用します。

FileSystemObjectの使い方

FileSystemObject」はフォルダやファイルを操作する際に使用するオブジェクトです。

FileSystemObjectは参照設定をするか「CreateObject」で使用できるようにします。

他のPCでコードを使いまわしても問題ないように今回はCreateObjectを使用します。

Sub Sample3()

Dim Fso     As Object

Set Fso = CreateObject("Scripting.FileSystemObject")

End Sub

サブフォルダを取得する

フォルダを取得するには「GetFolder」関数を使用します。

サブフォルダを取得するにはGetFolderで取得したフォルダ内「SubFolders」コレクションで取得できます。

GetFolderは指定されたフォルダーがない場合にエラーとなりますので、エラー処理が必要です。

次のコードはダイアログボックスで取得出来たフォルダ内のサブフォルダをすべて取得します。

「Sampleフォルダ」を指定して、その中のサブフォルダを取得したいと思います。

今回は次のような「Sampleフォルダ」内に「2016〜2019」のサブフォルダを用意しました。

Sub Sample4()

Dim myFolder    As Variant
Dim Fso         As Object
Dim GetFolder   As Object
Dim Fol         As Object

Set Fso = CreateObject("Scripting.FileSystemObject")

With Application.FileDialog(msoFileDialogFolderPicker)

    If .Show <> 0 Then
    
        myFolder = .SelectedItems(1)
    
    End If

End With

With CreateObject("WScript.Shell")

    .CurrentDirectory = myFolder

End With


Set GetFolder = Fso.GetFolder(myFolder)


For Each Fol In GetFolder.SubFolders

Debug.Print Fol.Name

Next

Set GetFolder = Nothing

End Sub

イミディエイトに2016〜2019のサブフォルダが取得できました。

3サブフォルダ内のファイルをすべて読み込む

サブフォルダを取得出来ましたので、次はサブフォルダ内のフィアルを全て読み込む方法です。

上記のサブフォルダの中にそれぞれの年度のファイルを用意しました。

(今回はファイルが1つですが、複数でも読み込みます。)

各ファイルには「1月~12月」と12個のシートがあります。

こちらの形式のファイルを4年分読み込みます。

もしシート名が同じである場合は、すでに同じシート名が存在する場合は2つ目以降のシートは自動的にナンバリングされますので、シート名を分岐条件にするなどの処理を組み込む以外は基本的にそのまま読み込んでも問題ありません。

Sub Sample5()

Dim myFolder    As Variant
Dim Fso         As Object
Dim GetFolder   As Object
Dim Fol         As Object
Dim Filename    As String
Dim IsBookOpen  As Boolean
Dim OpenBook    As Workbook
Dim ShCount     As Long

Set Fso = CreateObject("Scripting.FileSystemObject")

With Application.FileDialog(msoFileDialogFolderPicker)

    If .Show <> 0 Then
    
        myFolder = .SelectedItems(1)
    
    End If

End With

With CreateObject("WScript.Shell")

    .CurrentDirectory = myFolder

End With


Set GetFolder = Fso.GetFolder(myFolder)

For Each Fol In GetFolder.SubFolders 'サブフォルダをループ

    With CreateObject("WScript.Shell")
    
        .CurrentDirectory = Fol 'サブフォルダをカレントフォルダに指定
    
    End With
    
    'ここからサブフォルダ内のファイルを取得
    Filename = Dir("*.xlsx")
         
    Do While Filename <> ""
        
        If Filename <> ThisWorkbook.Name Then
        
            IsBookOpen = False
            
            For Each OpenBook In Workbooks
                        
                If OpenBook.Name = Filename Then
                
                    IsBookOpen = True
                    
                    Exit For
                    
                End If
                
            Next
            
            If IsBookOpen = False Then
                              
                ShCount = ThisWorkbook.Worksheets.Count
                          
                Workbooks.Open (Filename), UpdateLinks:=1
                
                Worksheets.Copy after:=ThisWorkbook.Worksheets(ShCount)
        
                Workbooks(Filename).Close savechanges:=False
                                       
            End If
            
        End If
        
        Filename = Dir()
        
    Loop

Next

Set GetFolder = Nothing

End Sub

すべて表示しきれませんが、4年分の48シートを読み込めました。

コードの説明

少し長いので、簡単にコードの説明です。

Application.FileDialog(msoFileDialogFolderPicker)」でフォルダを指定するダイアログを表示します。

myFolder = .SelectedItems(1)」で選択されたフォルダを取得しています。

Set GetFolder = Fso.GetFolder(myFolder)」で取得したフォルダをObjectへ格納しています。

For Each Fol In GetFolder.SubFolders」の「GetFolder.SubFolders」で格納したフォルダのサブフォルダをコレクションとしてループしています。

.CurrentDirectory = Fol」でコレクションから取得したフォルダをカレントフォルダにして、フォルダ内のファイルをループで取得しています。

これですべてのサブフォルダ内のファイルを読み込むことができました。

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