特定のフォルダにあるExcelファイルを全部開き、各A1の値をコピーして一つのファイルに集約する

特定のフォルダにあるExcelファイルを全て開き、その中身を集約する場面があった。そこで昔を振り返りながら、わがマクロの変遷を辿ってみる。
f:id:Infoment:20200114195030p:plain

例えば、↓ こんな感じでファイルが三つあるとする。
f:id:Infoment:20200114195123p:plain

実際の場面では、毎回何個か分からないだろうが、とりあえず今回は三個とする。
それぞのシートのA1には、食べ物の名前が入力されている。
f:id:Infoment:20200114195424p:plain

昔はとにかく、決め打ちだった。パスも固定で、一つずれれば手直しが必要。

Sub Test_1()
    Workbooks.Open ("C:\Temp\test1.xlsx")
    Range("A1").Copy
    ActiveWorkbook.Close
    
    Range("A1").PasteSpecial
    
    Workbooks.Open ("C:\Temp\test2.xlsx")
    Range("A1").Copy
    ActiveWorkbook.Close
    
    Range("A2").PasteSpecial
    
    Workbooks.Open ("C:\Temp\test3.xlsx")
    Range("A1").Copy
    ActiveWorkbook.Close
    
    Range("A3").PasteSpecial
End Sub

これを活かしつつ修正するとしたら、こんな感じかな。

Sub Test_1()
    Dim i As Long
        For i = 1 To 3
            Workbooks.Open ("C:\Temp\test" & i & ".xlsx")
            Range("A1").Copy
            ActiveWorkbook.Close
            
            Cells(i, 1).PasteSpecial
        Next
End Sub

しかし実際は、毎回こんな都合の良いファイル名であるはずもなく。

時が経ち、Dir関数を覚えた。定番の、Do ～ Loop との組み合わせだ。

Sub Test_2()
    Const FolderPath As String = "C:\Temp"
    Dim FileName As String
        FileName = Dir(FolderPath & "\*.xls*")
        
        Workbooks.Open (FolderPath & "\" & FileName)
        Range("A1").Copy
        ActiveWorkbook.Close False
        Range("A1").PasteSpecial
        
        FileName = Dir
        
        Do While FileName <> ""
            Workbooks.Open (FolderPath & "\" & FileName)
            Range("A1").Copy
            ActiveWorkbook.Close False
            Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial
            FileName = Dir
        Loop
End Sub

流石に各ファイルパスの決め打ちは無くなったものの、未だ全体的に野暮ったい。

そして更に時は流れ現在に至る。今ある知識で、贅の限りを尽くしたのがコチラ。

Sub Test_3()
    ' 画面更新の一時停止。
    ' ※ファイルの数だけ開いたり閉じたりするため。
    Application.ScreenUpdating = False
    
    ' ファイルが保存されたフォルダー。
    Const FolderPath As String = "C:\Temp"
    
    ' ファイル操作用。
    ' MicroSoft Scripting Runtime 参照済み。
    Dim FSO As Scripting.FileSystemObject
    Set FSO = New Scripting.FileSystemObject
    
    ' 値格納用。
    Dim Dict As Scripting.Dictionary
    Set Dict = New Scripting.Dictionary
      
    Dim File As Scripting.File
    ' フォルダー内の各ファイルについて処理。
        For Each File In FSO.GetFolder(FolderPath).Files
        
        ' 拡張子がExcelのものであることを確認する。
        ' ※xls*にすることで、xls，xlsx，xlsm，xlsbの全てに対応。
            If FSO.GetExtensionName(File.Path) Like "xls*" Then
                
                ' リンクの更新要求を避けるため、UpdateLinksはFalseとする。
                ' 編集不要なため、読み取り専用（ReadOnly）で開く。
                With Workbooks.Open(FileName:=File.Path, _
                                    UpdateLinks:=False, _
                                    ReadOnly:=True)
                    
                    ' ファイルパスをキーに、Ａ１の値をアイテムとして辞書に登録。
                    Dict(File.Name) = Range("A1").Value
                    
                    ' 用が済んだファイルを閉じる。
                    .Close False
                End With
            End If
        Next
        
        ' 辞書のアイテムは配列なので、シートに一括貼り付けできる。
        Range("A1").Resize(UBound(Dict.Keys) + 1) = WorksheetFunction.Transpose(Dict.Items)

    ' 画面更新停止の解除。
    Application.ScreenUpdating = True
End Sub