前提・実現したいこと
フォルダ内の全てのブック(サブフォルダ含む)指定シートのセルの値を指定したブックにコピーする
###ここに質問の内容を詳しく書いてください。
現在、集約表.xlsmというブックのSheet1にA1セルに、フォルダのアドレスを入力して、集約というコマンドボタンを押すとA4から「データ」というフォルダ内の全てのブックの「メニュー」SheetのA100:Y100までのデータをコピーする事が出来るのですが、全てのブックを「データ」フォルダにコピーし実行しているので容量をたくさん使用して困っています。
実際のフォルダ構成は
「データ」フォルダの中に「フォルダA」~「フォルダZ」が存在しA~Zフォルダには2000個のブックが存在します(各フォルダ内のブック数はバラバラです)
集約表.xlsmのSheet1のA1セルに「データ」フォルダのアドレスを入力してボタンを押したらフォルダA~Zの中にある全てのブックの「メニュー」SheetのA100~Y100を集約表.xlsmのSheet1のA4から順にコピーできるのか教えてください。
だらだらの長文で申し訳ありません、先輩から早く直せと言われ困っています、
該当のソースコード
Sub 集約()
'フォルダの場所を変数に入れる
Dim Folder_path As String
Folder_path = Range("a1").Value
'集計先のシートを指定し、変数に入れる
Dim w
Set w = Worksheets("sheet1")
'集計するブックを変数に入れる
Dim Merge_book As String
Merge_book = Dir(Folder_path & ".xlsm")
'いったん数値をクリア
w.Range("b" & Rows.Count).Clear
'集計先のシートの4行からスタート
Dim n
n = 4
'指定したフォルダから、Excelファイルを探す
Do Until Merge_book = ""
Workbooks.Open FileName:=Folder_path & "" & Merge_book
'見つかったら、A列にファイル名、B列に集計値を入れる
w.Range("a" & n).Value = Merge_book
w.Range("b" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("a100").Value
w.Range("c" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("b100").Value
w.Range("d" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("c100").Value
w.Range("e" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("d100").Value
w.Range("f" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("e100").Value
w.Range("g" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("f100").Value
w.Range("h" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("g100").Value
w.Range("i" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("h100").Value
w.Range("j" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("i100").Value
w.Range("k" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("j100").Value
w.Range("l" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("k100").Value
w.Range("m" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("l100").Value
w.Range("n" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("m100").Value
w.Range("o" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("n100").Value
w.Range("p" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("o100").Value
w.Range("q" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("p100").Value
w.Range("r" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("q100").Value
w.Range("s" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("r100").Value
w.Range("t" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("s100").Value
w.Range("u" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("t100").Value
w.Range("v" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("u100").Value
w.Range("w" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("v100").Value
w.Range("x" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("w100").Value
w.Range("y" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("x100").Value
w.Range("z" & n).Value = Workbooks(Merge_book).Worksheets("メニュー").Range("y100").Value
'次の行へ
n = n + 1
'集計するブックを閉じる
Workbooks(Merge_book).Close
'次のファイルを探しに行く
Merge_book = Dir()
Loop
End Sub
ソースコード
試したこと
サブフォルダを探しに行くのだと思い色々試したのですがうまくいきませんでした
補足情報(FW/ツールのバージョンなど)
win10 エクセル2016 です
回答1件
あなたの回答
tips
プレビュー
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
2020/02/27 00:05
2020/02/27 00:48
2020/02/27 08:15