VBAでのサブフォルダ内のエクセル集約について

質問

VBAを使って所定のフォルダ内のデータを集計するプログラムをネットで調べ、
以下のように作ってみたのですが、
サブフォルダ内のデータも同じように集計することはできないでしょうか？
以下のプログラムは正常に機能していて、「データフォルダ」直下にあるエクセルは
集計できています。

※「データフォルダ」内に、都道府県別のフォルダが用意され、その中に市区町村別のエクセルが配置されている感じです。
※EXCEL2013環境です。

Sub 全国集計()
Const FolderPath As String = "\\C:\データフォルダ"
Application.ScreenUpdating = False
Range("6:1048576").Delete
Dim objFSO As Object
Dim objBook As Object
Dim lngRow As Long
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objBook In objFSO.GetFolder(FolderPath).Files
lngRow = ThisWorkbook.Sheets("data").Range("A" & Rows.Count).End(xlUp).Row + 1
Workbooks.Open objBook.Path
With ActiveWorkbook
.Sheets("data").Rows("5:105").Copy ThisWorkbook.Sheets("data").Rows(lngRow)
.Close
End With
Next
Set objFSO = Nothing
ActiveWindow.ScrollRow = 1
ActiveWindow.ActiveSheet.Range("A1").Select
Application.ScreenUpdating = True
End Sub

回答No.2

imogasi

（１）Ｄｉｒ関数を使う（Ｄｏｓ時代のコマンドの流れを引き継ぐ）
（２）ＦＳＯを使う
また
（Ａ）再帰を使う
（Ｂ）再帰を使わない
があるが、
ＷＥＢの解説実例を借りて、多少修正してテストしました。
上記の（１）の（Ａ）のパターンです。
ーー
データ例作成（私の場合は適当なデータ例がないので）
「計数例」というフォルダ名のフォルダを作り
その下に
ｆｌｄ１
ｆｌｄ２
ｆｌｄ３
という名のフォルダを作り
ｆｌｄ２に下にはサブフォルダを２つ
subfld21
subfld2２
を作りました。
各フォルダかサブフォルダには１つのブックを入れて
各ブックのＳｈｅｅｔ１は
売上 人員
東京 235 18
名古屋 163 15
大阪 165 16
のようなシートを作り、各ブックで数字だけ違うシートにしました。
ーーー
標準モジュールに
Sub sample()
Dim i As Long
Dim aryDir() As String
Dim aryFile() As String
Dim strName As String
MsgBox CurDir & "\計数例"
MsgBox ThisWorkbook.Name
Set wb0 = ActiveWorkbook
i = 0
ReDim aryDir(i)
aryDir(i) = CurDir & "\計数例" 'フォルダをここで指定
'まずは、指定フォルダ以下の全サブフォルダを取得し、配列aryDirに入れます。
Do
strName = Dir(aryDir(i) & "\", vbDirectory)
Do While strName <> ""
If GetAttr(aryDir(i) & "\" & strName) And vbDirectory Then
If strName <> "." And strName <> ".." Then
ReDim Preserve aryDir(UBound(aryDir) + 1)
aryDir(UBound(aryDir)) = aryDir(i) & "\" & strName
End If
End If
strName = Dir()

Loop
i = i + 1
If i > UBound(aryDir) Then
Exit Do
End If
Loop

'配列aryDirの全フォルダについて、ファイルを取得し、配列aryFileに入れます。
ReDim aryFile(0)
k = 1
For i = 0 To UBound(aryDir)
strName = Dir(aryDir(i) & "\", vbNormal + vbHidden + vbReadOnly + vbSystem)
Do While strName <> ""
If aryFile(0) <> "" Then
ReDim Preserve aryFile(UBound(aryFile) + 1)
End If
aryFile(UBound(aryFile)) = aryDir(i) & "\" & strName
'実行結果が分かりやすいように、テスト的にセルに書き出す場合
'Cells(UBound(aryFile) + 1, 1) = aryFile(UBound(aryFile))
Cells(k, "A") = aryFile(UBound(aryFile))
Set wb = Workbooks.Open(aryFile(UBound(aryFile)))
MsgBox wb.Worksheets("Sheet1").Range("B2").Value
'Cells(UBound(aryFile) + 1, 2) = wb.Worksheets("Sheet1").Range("B2").Value 'この例では東京の売上額
Workbooks("フォルダファイル合計").Worksheets("Sheet1").Cells(k, "G") = _
wb.Worksheets("Sheet1").Range("B2").Value 'この例では東京の売上額
k = k + 1
wb.Close SaveChanges:=False
strName = Dir()
Loop
Next
End Sub
ーー
実行すると
結果
C:\Users\惇\Documents\計数例\fld1\計数例１1.xlsm 235
C:\Users\惇\Documents\計数例\fld3\計数例31.xlsm 279
C:\Users\惇\Documents\計数例\fld2\subfld21\計数例2１.xlsm 265
C:\Users\惇\Documents\計数例\fld2\subfld22\計数例22.xlsm 253
右の「２３５」などは「東京」の「売上」を本プログラムが拾ってきたものです。
Ｍｓｇｂｏｘ　は確認用なので、納得後削除。
Screenupdatingは上記にはいれてないが入れてください。

回答No.1

dogs_cats

VBAが記載してあるブックに、データを集約させるコードですよね。
サブフォルダがいくつあるかによりますが、今のコードをコピペして若干修正で如何でしょう。

上記VBAをコピペして
Range("6:1048576").Deleteを削除
Const FolderPath As String をサブフォルダ指定下記○○が該当
Const FolderPath As String =\\C:\データフォルダ\○○"

Sub 全国集計()実行
修正VBA実行
サブフォルダ名を修正して実行を繰り返す。

お礼

ありがとうございます。
私も当初その方法でコピペして対応しようとしたのですが、
「コンパイルエラー：同じ適用範囲内で宣言が重複しています。」
とのエラーが出て、どうしてもできませんでした。
VBAって難しいですね。。