VBAに関する質問（特定フォルダのすべてのファイルに実行する処理でループ処理が働かない）

Question

マクロで特定のフォルダにあるすべてファイルのセル”A2：B2”をコピーして、
指定したファイルに自動転記したいです。

下記コードを作成して、実行してみたところ、動作はしますが
すべてのファイルを実行するようなループ処理が働きません。
テストした際は、特定フォルダに３つのファイルを格納しましたが、
１つのファイルのみの”A2：B2”がコピペされているようでした。
当方初心者で原因がどうしてもわからないので、教えていただけると幸いです。

ーーーーーーー以下書いたコード

VBA
コード

Sub 一括取込()
 Dim folderPath As String
 Dim filePath As String

  With Application.FileDialog(msoFileDialogFolderPicker)
      .Title = "取込場所の選択"  'タイトルの指定
      .InitialFileName = ""      '初期表示フォルダの指定
  If .Show = True Then           'ダイアログを表示して戻り値を判定
      folderPath = .SelectedItems(1) 'フォルダのパスを取得
  Else
     Exit Sub
  End If
 End With
 
 With Application.FileDialog(msoFileDialogFilePicker)
      .Title = "転記先の選択"  'タイトルの指定
      .InitialFileName = ""      '初期表示フォルダの指定
  If .Show = True Then           'ダイアログを表示して戻り値を判定
      filePath = .SelectedItems(1) 'ファイルのパスを取得
  Else
     Exit Sub
  End If
 End With
 
 
 Dim myPath As String, myBook As String, last As Integer, i As Long
 Dim wb1 As Workbook, wb2 As Workbook
 Dim ws1 As Worksheet, ws2 As Worksheet
   
 myPath = folderPath
 myBook = Dir(myPath & "\*.xlsx") 'ワイルドカード(*)を使用し、xlsx拡張子のファイルをすべて
 
 Set wb1 = Workbooks.Open(filePath)
 Set ws1 = wb1.Sheets("Sheet1")
 
 Application.ScreenUpdating = False 'ちらつき防止
 
 filePath = Dir(filePath)
 Workbooks.Open filePath
  
 Do While myBook <> ""
    Set wb2 = Workbooks.Open(myPath & "\" & myBook)
    Set ws2 = wb2.Sheets("Sheet1")
        
    ws2.Range("A2:E2").Copy
    last = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Offset(1).Row
    ws1.Range("A" & last).PasteSpecial Paste:=xlPasteValues　’コピーしたファイルを最終行の下にペースト
               
    Set ws2 = Nothing
    Set wb2 = Nothing
    myBook = Dir()
Loop

Application.ScreenUpdating = True 'ちらつき防止

wb1.Save
Set ws1 = Nothing
Set wb1 = Nothing
End Sub

Comments

[hatena19]

コードの一部しかマークダウンのコードブロックに入っていません。
コード全体を下記のようにコードブロック内に入れてください。

```vba
ここにコード全体
```

[kkkrw]

失礼いたしました。コードブロックを修正いたしました。

Answer 1

処理としては、下記の３つになります。

• 取込元フォルダの選択
• 転記先ブックを選択して開く
• 取込元フォルダのxlsxファイルのループ処理

これらの処理をそれぞれ纏めて記述すると読みやすくなると思います。(好みはあると思いますが)
現状はこれらが混ざっているので混乱しているようです。

あと、Dir関数でフォルダ内ファイルをループするときは、下記のようなコードになります。

myBook = Dir(フォルダパス)
Do While myBook <> ""
   'ブックに対する処理
    myBook = Dir()
Loop

上記を考慮して、修正すると下記のようなコードになります。

Sub 一括取込()
    '取込元フォルダの選択
    Dim folderPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "取込場所の選択"                       'タイトルの指定
        .InitialFileName = ""                    '初期表示フォルダの指定
        If .Show = True Then                     'ダイアログを表示して戻り値を判定
            folderPath = .SelectedItems(1)       'フォルダのパスを取得
        Else
            Exit Sub
        End If
    End With
    
    '転記先ブックの選択
    Dim filePath As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "転記先の選択"                        'タイトルの指定
        .InitialFileName = ""                    '初期表示フォルダの指定
        If .Show = True Then                     'ダイアログを表示して戻り値を判定
            filePath = .SelectedItems(1)         'ファイルのパスを取得
        Else
            Exit Sub
        End If
    End With
    Dim wb1 As Workbook, ws1 As Worksheet
    Set wb1 = Workbooks.Open(filePath) '転記先ブックを開く
    Set ws1 = wb1.Sheets("Sheet6")

'    Application.ScreenUpdating = False           'ちらつき防止
    
    '取込場所フォルダのxlsxファイルのループ処理
    Dim myBook As String, lastCell As Range
    Dim wb2 As Workbook, ws2 As Worksheet
    myBook = Dir(folderPath & "\*.xlsx")   'xlsx拡張子の最初のファイル名を取得
    Do While myBook <> ""
        Set wb2 = Workbooks.Open(folderPath & "\" & myBook)
        Set ws2 = wb2.Sheets("Sheet1")

        ws2.Range("A2:E2").Copy
        Set lastCell = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Offset(1) '最終行の下のセルを取得
        lastCell.PasteSpecial Paste:=xlPasteValues
        wb2.Close '開いたブックは閉じる
           
        myBook = Dir() 'xlsx拡張子の次のファイル名を取得
    Loop
    Set wb2 = Nothing

    Application.ScreenUpdating = True            'ちらつき防止

    wb1.Save
    Set ws1 = Nothing
    Set wb1 = Nothing
End Sub

Comments

[kkkrw]

ありがとうございます。無事に処理ができました。
ご説明も非常にわかりやすかったです。