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

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

ただいまの
回答率

87.59%

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

解決済

回答 1

投稿

  • 評価
  • クリップ 0
  • VIEW 4,259

score 5

前提・実現したいこと

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

ここに質問の内容を詳しく書いてください。

現在、集約表.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 です

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

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

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

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 1

checkベストアンサー

0

だらだらの長文で申し訳ありません、先輩から早く直せと言われ困っています、
まず箇条書きにしてみて、それから何度も推敲して、
他人にちゃんと伝わるか考えてみてから発言してみては?

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

Option Explicit

'※メニュー[ツール]→[参照設定]で、「Microsoft Scripting Runtime」にチェック

Sub メイン()
    Dim FSO As FileSystemObject: Set FSO = New FileSystemObject
    Dim o As Folder
    Dim f As File
    Dim i As Long

    i = 4
    For Each o In FSO.GetFolder("C:\Users\Public\Documents\てすと").SubFolders
        For Each f In o.Files
            If FSO.GetExtensionName(f) = "xlsx" Then
                With Workbooks.Open(f.Path)
                    .Worksheets(1).Range("A100:Y100").Copy wshResults.Cells(i, "B")
                    .Close False
                End With
                i = i + 1
            End If
        Next
    Next
End Sub


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

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2020/02/27 09: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が反転し止まってしまうのですがどうしたらよいでしょうか。何度も申し訳ありません。

    キャンセル

  • 2020/02/27 09:48

    >If FSO.GetExtensionName(f) = "xlsx" Then はxlsmでしょうか?xlsxのままでしょうか?
    そこはご自分の環境に合わせて、どの形式のファイルを対象にされるかで変えてください。

    あ、すみません。
    変数の宣言&代入を忘れてますね^^;

    dim wshResults as worksheet
    set wshResults = thisworkbook.worksheets(1) '←転記先のシートを代入

    の行を適切なところに入れてください。
    わかりますでしょうか?
    ちょっと時間が無いのでお昼にでも見直します。

    別の書き方をしてテストしてたんですが、貼り付けるときに書き換えて、
    間違いがあったようです。すみません。

    キャンセル

  • 2020/02/27 17:15

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

    キャンセル

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

  • ただいまの回答率 87.59%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

同じタグがついた質問を見る

  • トップ
  • VBAに関する質問
  • フォルダ内の全てのサブフォルダのブックから指定シートの指定セルの値をコピーする