質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

新規登録して質問してみよう
ただいま回答率
85.50%
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

Q&A

解決済

1回答

7509閲覧

フォルダ内の全てのサブフォルダのブックから指定シートの指定セルの値をコピーする

natsupin0519

総合スコア5

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

0グッド

0クリップ

投稿2020/02/26 08:33

前提・実現したいこと

フォルダ内の全てのブック(サブフォルダ含む)指定シートのセルの値を指定したブックにコピーする

###ここに質問の内容を詳しく書いてください。
現在、集約表.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 です

気になる質問をクリップする

クリップした質問は、後からいつでもMYページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

guest

回答1

0

ベストアンサー

だらだらの長文で申し訳ありません、先輩から早く直せと言われ困っています、

まず箇条書きにしてみて、それから何度も推敲して、
他人にちゃんと伝わるか考えてみてから発言してみては?

1)サブフォルダー毎に繰り返し
2)ファイル毎に繰り返し
3)もし、ファイルがエクセルファイルなら
4)ファイルを開く
5)一番左のシートの100行目をコピペ
6)ファイルを閉じる
7)2へ戻る
8)1へ戻る

ExcelVBA

1Option Explicit 2 3'※メニュー[ツール]→[参照設定]で、「Microsoft Scripting Runtime」にチェック 4 5Sub メイン() 6 Dim FSO As FileSystemObject: Set FSO = New FileSystemObject 7 Dim o As Folder 8 Dim f As File 9 Dim i As Long 10 11 i = 4 12 For Each o In FSO.GetFolder("C:\Users\Public\Documents\てすと").SubFolders 13 For Each f In o.Files 14 If FSO.GetExtensionName(f) = "xlsx" Then 15 With Workbooks.Open(f.Path) 16 .Worksheets(1).Range("A100:Y100").Copy wshResults.Cells(i, "B") 17 .Close False 18 End With 19 i = i + 1 20 End If 21 Next 22 Next 23End Sub 24

こういうことかな?
遅くて不満なら、勉強して違うやり方を覚えてください。
後で読んで何してるかわかりやすいとは思います。
参照設定を忘れずに!

投稿2020/02/26 09:39

mattuwan

総合スコア2136

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

natsupin0519

2020/02/27 00:05

早速の回答ありがとうございます、メニュー[ツール]→[参照設定]で、「Microsoft Scripting Runtime」にチェックを入れ、集約表.xlsmの標準モジュールにVBAを入力し  For Each o In FSO.GetFolder("C:\Users\Public\Documents\てすと").SubFoldersの部分を変更し If FSO.GetExtensionName(f) = "xlsx" Then はxlsmでしょうか?xlsxのままでしょうか?入力しましたが、.Worksheets(1).Range("A100:Y100").Copy wshResults.Cells(i, "B")のwshResultsが反転し止まってしまうのですがどうしたらよいでしょうか。何度も申し訳ありません。
mattuwan

2020/02/27 00:48

>If FSO.GetExtensionName(f) = "xlsx" Then はxlsmでしょうか?xlsxのままでしょうか? そこはご自分の環境に合わせて、どの形式のファイルを対象にされるかで変えてください。 あ、すみません。 変数の宣言&代入を忘れてますね^^; dim wshResults as worksheet set wshResults = thisworkbook.worksheets(1) '←転記先のシートを代入 の行を適切なところに入れてください。 わかりますでしょうか? ちょっと時間が無いのでお昼にでも見直します。 別の書き方をしてテストしてたんですが、貼り付けるときに書き換えて、 間違いがあったようです。すみません。
natsupin0519

2020/02/27 08:15

完璧です、これで仕事が進みます。ありがとうございました。
guest

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

15分調べてもわからないことは
teratailで質問しよう!

ただいまの回答率
85.50%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問