複数ブック、複数シートからの値コピー

Question

前提・実現したいこと

［実現したいこと］
VBAにて集計表を作成しております。
勉強をし始め、数日です。
複数ブックの複数シートから値のみコピーしたいと思っています。

［前提］
・集計元は1つのフォルダにまとまっている
・集計元は複数のブックにわかれている
またBookの名前もまちまちである。
Book1.xlsx、ABC.xlsx、111.xlsx･･･
・集計元の1つのブックには複数のシートが含まれている
シートの枚数、名前はブックによってまちまち
・各シートはブックが分かれていても全て共通のフォーマット

①集計元のブック（元データが記載されている）の各シートのA2のセルをコピー　→　集計先のB列に貼り付け
②集計元のブック（元データが記載されている）のD2のセルをコピー　→　集計先のC列に貼り付け
③集計元のブック、シート名をA列にはりつけ

ということをおこないたいです。
やりたいことと乖離してしまっているためご教示を頂きたいです。

発生している問題・エラーメッセージ

まず前提の①が行えるか試した所、以下を実行すると
1つ目のブックの各シートをコピーしましたが
2つ目のブックを開いたあと、1つ目の下データのブックの値に上書きされてしまいました。

また②の、集計元のブック（元データが記載されている）のD2のセルをコピー　→　集計先のB列に貼り付けに関しても変数が複数になると理解がおいついておりません。

言い訳にするつもりではないのですが、
勉強が浅いため、作成したコードもお見苦しい点ばかりかと思います。
何卒お力お借りしたく思います。

該当のソースコード

Sub TEST()
Dim myPath As String
Dim myFile As String
Dim i As Long
 
myPath = ThisWorkbook.Path
myFile = Dir(myPath & "\" & "*.xlsx") 

Do Until myFile = ""

Workbooks.Open myPath & "\" & myFile 
Sheets("Sheet1").Select
For i = 1 To Worksheets.Count

Worksheets(i).Range("A2").Copy

ThisWorkbook.Worksheets("Sheet1").Cells(i, 1).PasteSpecial _
xlPasteValuesAndNumberFormats

Next i

myFile = Dir()

Loop
End Sub

Comments

[coco_bauer]

複数のシートを持つ複数のブックから、A2セルとD2セルの内容を収集するだけで良いのですか？　情報源となったブックの名前とワークシートの名前ぐらいは残さないと、後で困るのではないかと危惧します。

[m73]

＞coco_bauer様　　仰られるとおりです、ご指摘切に感謝いたします。質問を一部編集させて頂きます。

[m.ts10806]

プログラムコード(およびエラーメッセージ)は```で囲ってください。（わからなければ質問編集画面でコード部分を選択し<code>ボタンを押してください）正しく反映されているかどうかは質問編集画面のプレビューを見ながら編集していってください。

[m73]

＞mts10806様　失礼いたしました。ご指摘感謝いたします。早々に修正いたします。

Answer 1

まずは、確認。
集計元と集計先のブックは同じフォルダーにあるのですか。
（コードを見る限りは同じフォルダーですね。）
また、このマクロは集計先のファイルにあるのですね。

上記があっているとして、

DoループでDir関数を使ってファイル名を順次取得する部分と、Forループで各シートを順次取得して処理していく部分はいいですが、Forのループ変数(i)を行インデックスしているのが間違いですね。
別ブックへ移行するときに、1 に戻ってしまいますので、同じところを上書きすることになります。

入力行用の変数を別に用意して、カウントアップするようにする必用があります。

現状のコードをなるべく活かして、上記の点と、A列にブック名!シート名の入力も追加したコード例をとりあえず提示します。

Sub 取り込みテスト()
    Dim myPath As String
    Dim myFile As String
    Dim MyBook As Workbook
    Dim CurRow As Long '入力する行インデックス
    Dim i As Long

    myPath = ThisWorkbook.Path
    myFile = Dir(myPath & "\" & "*.xlsx")
    CurRow = 1
    Do Until myFile = ""
        Workbooks.Open myPath & "\" & myFile
'       Sheets("Sheet1").Select ←不必要だし、「Sheet1」という名前のシートがなければエラーになる
        For i = 1 To Worksheets.Count
            Worksheets(i).Range("A2").Copy
            ThisWorkbook.Worksheets("Sheet1").Cells(CurRow, 2).PasteSpecial _
                    xlPasteValuesAndNumberFormats
            Worksheets(i).Range("D2").Copy
            ThisWorkbook.Worksheets("Sheet1").Cells(CurRow, 3).PasteSpecial _
                    xlPasteValuesAndNumberFormats
            ThisWorkbook.Worksheets("Sheet1").Cells(CurRow, 1).Value = myFile & "!" & Worksheets(i).Name
            CurRow = CurRow + 1 '入力行をカウントアップ
        Next i

        myFile = Dir()
    Loop

End Sub

これで希望の動作にはなると思います。
ただ、アクティブブック、シートが移動するのでチラツキますし、
クリップボード経由なので処理も重いです。
また、ブックが開きっぱなしなのも気になりますね。

この辺りは完全の余地が大です。
ヒントを出しておきますと、
Application.ScreenUpdating を使って画面更新を抑止するとチラツキを抑制できます。
Copy PasteSpecial を使わなくても、代入という処理で値を入力できます。

追記

タッチの差で、imihitoさんに先を越されました。しかも、より完成度の高いコードです。
まずは、私のコードは、元のコードとほぼと同じなので意味はすぐ理解できると思います。
それを理解した上で、imihitoさんのコードを、私との違いを意識しながら、読むと理解が捗ると思います。

上記のコードの改良版

Sub 取り込みテスト()
    Dim myPath As String
    Dim myFile As String
    Dim FromBook As Workbook '集計元ブック
    Dim ToSheet As Worksheet '集計先シート
    Dim CurRow As Long '入力する行インデックス
    Dim i As Long

    Set ToSheet = ThisWorkbook.Worksheets("Sheet1") '
    myPath = ThisWorkbook.Path & "\"
    myFile = Dir(myPath & "*.xlsx")
        
    Application.ScreenUpdating = False '画面更新の抑制
    
    CurRow = 1
    Do Until myFile = ""
        Set FromBook = Workbooks.Open(myPath & "\" & myFile) '開いたブックを変数にセット
        For i = 1 To FromBook.Worksheets.Count
            With FromBook.Worksheets(i)
                ToSheet.Cells(CurRow, 1).Value = myFile & "!" & .Name
                ToSheet.Cells(CurRow, 2).Value = .Range("A2").Value
                ToSheet.Cells(CurRow, 3).Value = .Range("D2").Value
            End With
            CurRow = CurRow + 1 '次の行に移動
        Next i
        FromBook.Close '集計元ブックを閉じる
        myFile = Dir()
    Loop
    Application.ScreenUpdating = True
    
    MsgBox "取り込み完了しました。"
End Sub

Answer 2

変数が複数になると理解がおいついておりません。

変数は使いたい値に対するメモのようなものです。
メモの名前が適当だと何を表しているのかわかりにくいため、自分がわかりやすい名前を付けてあげると上手くようになると思います。

VBAのデバッグ時に便利な機能

ローカルウィンドウ

ローカル変数（プロシージャの中で作った変数）の中身を簡単に確認できるウィンドウです。
ステップ実行や、ブレークポイントと組み合わせると、今どんな状態なのか、を簡単に確認できます。

イミディエイトウィンドウ

ローカルウィンドウで変数の中はある程度は見えますが、一部確認できないものもあります。
そのような場合は、イミディエイトウィンドウを使用すると、その場で簡単なコードを実行して結果を確認できます。

'イミディエイトウィンドウ内：値の確認
?Range("A1").Value '~Valueまで入力してEnter→A1セルの値が表示される

'イミディエイトウィンドウ内：何か実行
Range("A1").Select '~Selectまで入力してEnter→A1セルが選択される

---

①集計元のブック（元データが記載されている）の各シートのA2のセルをコピー　→　集計先のB列に貼り付け

の部分だけサンプルを作ってみました。

若干変数過多の気はありますが参考になれば。

Sub TEST2()
    
    'コピー先のシート
    Dim copyToSheet As Worksheet
    Set copyToSheet = ThisWorkbook.Worksheets("Sheet1")
    
    '集計元A2セルのコピー先（開始位置）
        '適当な名前なので、値の意味を踏まえた名前にした方が良い
    Dim A2CopyToCell As Range
    Set A2CopyToCell = copyToSheet.Range("B1")
    
    'xlsxファイルを検索するフォルダ（末尾\付き）
        'ThisWorkbook.Path & "\" はなんども出てくるので先にまとめてしまう
    Dim searchFolderPath As String
    searchFolderPath = ThisWorkbook.Path & "\"
    
    '見つかったxlsxファイルの名前
    Dim findXlsxName As String
    findXlsxName = Dir(searchFolderPath & "*.xlsx")
    
    Do Until findXlsxName = ""
        
        'コピー元のブックを開く
        Dim copyFromBook As Workbook
        Set copyFromBook = Workbooks.Open(searchFolderPath & findXlsxName)
        
        'For Each は「何かの集まり全て」（今回は`copyFromBook`のワークシート全て）に対して処理をする
        Dim ws As Worksheet
        For Each ws In copyFromBook.Worksheets
            '`ws`には 元のコードでの`Worksheets(i)`に相当するものが自動で入ります
            
            '①集計元のブック（元データが記載されている）の各シートのA2のセルをコピー　→　集計先のB列に貼り付け
            Dim A2CopyFromCell As Range
            Set A2CopyFromCell = ws.Range("A2")
            
            'コピー先のセルの値にコピー元のセルの値を入れる
            A2CopyToCell.Value = A2CopyFromCell.Value
            
            
            '次のコピー先のセルは、今のコピー先のセルから1行0列動いたセル（→1つ下のセル）
            Set A2CopyToCell = A2CopyToCell.Offset(1, 0)
            
            '②集計元のブック（元データが記載されている）のD2のセルをコピー　→　集計先のC列に貼り付け
            'TODO
            
            '③集計元のブック､シート名をA列にはりつけ
            'TODO
                '集計元のブックの名前→copyFromBook.Name
                'シート名→ws.Name
            
            
        Next ws
        
        findXlsxName = Dir()
        
    Loop
    
End Sub