他のEXCELファイルデータをループで取得する方法について

Question

「Book①.xlsx」から「Book②.xlsm」にデータを取得する事はできたのですが、ループ処理がわかりません。

VBAの勉強を始めたばかりの初心者です。
「Book②.xlsm」に画像のとおり取り込みファイルパス等を記載しています。この情報をもとに「Book①.xlsx」から「Book②.xlsm」にデータを取得するというマクロを作成しました。

以下、No1の行のみ実行するコードです。
No2以降も空白になるまで繰り返し実行するコードに修正したいのですが、調べて色々試しましたがわかりませんでした。どのようなコードを記載したらよいのでしょうか。

'「取り込むEXCELファイルのパス」と「取り込むEXCELファイルのデータが存在するシートNO」を引数に持つEXCEL関数を作成。
Public Function GetExcelData(ByVal FilePath As String, ByVal SheetNo As String) As Variant
    Dim wb As Workbook
    Dim ws As Worksheet
    
    'ワークブックを開く
    Set wb = Workbooks.Open(FilePath)
    
    'シートを取得
    Set ws = wb.Worksheets(SheetNo)
    
    'データ入力されている範囲を取得する
    GetExcelData = ws.UsedRange
    
    'ワークブックを閉じる
    wb.Close
    
    'メモリー開放
    Set ws = Nothing
    Set wb = Nothing
    
End Function

'次に、先程のEXCELデータ取り込み関数を利用する関数を作成。（No.1のデータ取り込み））
Public Sub Macro1()
    Dim var As Variant
    Dim FilePath As String
    Dim InSheetNo As String
    Dim OutSheetNo As String
    Dim OutCell As String

    
    With ThisWorkbook.Sheets(1)
        FilePath = .Range("B2")
        InSheetNo = .Range("C2")
        OutSheetNo = .Range("D2")
        OutCell = .Range("E2")
        row = row + 1
    End With

    
    '他のEXCELファイルデータを取り込む
    var = GetExcelData(FilePath, InSheetNo)
    
    Dim MaxRow As Long
    Dim MaxCol As Long
    
    '最大行数を取得する
    MaxRow = UBound(var, 1)
    
    '最大列数を取得する
    MaxCol = UBound(var, 2)
    
    '自ワークブックの1番目のシートのセルA1を基点に取り込んだデータを出力する
    ThisWorkbook.Sheets(OutSheetNo).Range(OutCell).Resize(MaxRow, MaxCol).Value = var
    
End Sub

Answer 1

こんな感じ？

Option Explicit

Sub Main()
    Dim rngBody As Range
    Dim r As Range
    
    'リストのデータ範囲取得
    Set rngBody = GetListBody(ThisWorkbook.Worksheets(1), "B2", 4)
    
    '行毎に繰り返し
    For Each r In rngBody.Rows
        With WorksheetFunction
            DataIn .Transpose(.Transpose(r))    'データの転記(一次配列で渡す）
        End With
    Next
End Sub

'**********************************
'一覧表のデータ範囲の取得関数
'第１引数：対象シート
'第２引数：左上セルアドレス
'第３引数：表の列数
'返り値：セル範囲
'***********************************
Private Function GetListBody(ByRef ws As Worksheet, _
                            ByVal a As String, _
                            ByVal c As Long) As Range
    Dim rngBottom As Range
    With ws.Range(a)
        Set GetListBody = Application.Range(.Cells, .End(xlDown)).Resize(, c)
    End With
End Function

'***************************************************
'データの転記
'第１引数：元ファイルパス、元シート名、先シート名、先セルアドレスを一次配列で指定
'*****************************************************
Private Sub DataIn(ByVal v As Variant)
    Dim wbk As Workbook
    Dim wsh As Worksheet
    
    'ファイルの存在確認
    If Len(Dir(v(1))) > 0 Then
        Set wbk = Workbooks.Open(v(1))
    Else
        MsgBox "指定のファイルがありません."
        Exit Sub
    End If
    
    'シートの存在確認
    On Error Resume Next
    Set wsh = wbk.Worksheets(v(2))
    On Error GoTo 0
    If wsh Is Nothing Then
        MsgBox "指定のシートがありません。"
        GoTo WayOut
    End If
    
    'データの転記
    With wsh.UsedRange
        ThisWorkbook.Worksheets(v(3)).Range(v(4)).Resize(.Rows.Count, .Columns.Count).Value = .Value
    End With
    
WayOut:
    wbk.Close False
End Sub

あ、

＞.End(xlDown)

データが２つ以上ないと、おかしなことになりますね＾＾；
ちょっとセル範囲の指定を工夫してみてください。

Comments

[yokoazu]

ありがとうございます。セル範囲工夫して考えてみます。
初心者すぎて何時間も考えてしまうので、質問後すぐ教えていただきすごいなと思っています。
頂いた回答で勉強させていただこうと思います。

[mattuwan]

慣れですよ。何十回、何百回でもたくさんコードをみて、たくさんコード書くといいと思います。
エクセルVBAの質問掲示板はここ以外にもいくつかあるので、
回答のコードをいっぱいみたり、質問に対して自分ならどう書くか考えてみたりして経験を補うとよいかと。
セル範囲で、一番下のデータのセルを探すときは、シートの一番下からEnd(xlup)で検索するのが、
常套手段となります。
VBAの解説サイトもいくつかあるので、探してみましょう。

[yokoazu]

慣れなんですね。はじめたばかりでサッパリわからなくて。
実行したい内容が１つでもコードの書き方は色々あるんですね。質問へ回答するのも経験になるのかぁ・・・まだまだ先の話ですが、知識がついてきたら回答者として経験積みたいと思います。まずは回答のコードを色々見てみます。

そうなんですね。覚えておきます！他にもサイト見てみようとおもいます。
勉強のしかたまで親切にアドバイス頂き感謝いたします。
＞セル範囲で、一番下のデータのセルを探すときは、シートの一番下からEnd(xlup)で検索するのが、
常套手段となります。

Answer 2

Public Sub Macro1()のみ修正すればOKです。
以下のようにします。

Public Sub Macro1()
    Dim var As Variant
    Dim FilePath As String
    Dim InSheetNo As String
    Dim OutSheetNo As String
    Dim OutCell As String
    Dim maxrow_A As Long
    Dim wrow As Long
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Sheets(1)
    maxrow_A = sh.Cells(Rows.count, "A").End(xlUp).row    'A列の最大行取得
    For wrow = 2 To maxrow_A

        FilePath = sh.Cells(wrow, "B").Value
        InSheetNo = sh.Cells(wrow, "C").Value
        OutSheetNo = sh.Cells(wrow, "D").Value
        OutCell = sh.Cells(wrow, "E").Value


        '他のEXCELファイルデータを取り込む
        var = GetExcelData(FilePath, InSheetNo)

        Dim maxrow As Long
        Dim MaxCol As Long

        '最大行数を取得する
        maxrow = UBound(var, 1)

        '最大列数を取得する
        MaxCol = UBound(var, 2)

        '自ワークブックの1番目のシートのセルA1を基点に取り込んだデータを出力する
        ThisWorkbook.Sheets(OutSheetNo).Range(OutCell).Resize(maxrow, MaxCol).Value = var
    Next
End Sub

Comments

[yokoazu]

もとのコードを修正したかたちでとてもわかりやすかったです。ありがとうございます。
実行したところデータ取得は成功したのですがエラー400が表示されてしまいます。
何からなにまで申し訳ないのですが、このエラー解消はどのようにしたら良いのでしょうか。

[tatsu99]

こちらでは、３行分（３ブック）の処理が正常に処理できたことを確認しています。
エラー４００が発生するのは、どの行でしょうか？

[yokoazu]

１行のみの場合でも、２行の場合でも３行の場合でもエラー400となってしまいます。
tatsuさんが正常に処理できたという事はコード以外の問題も考えられるのでしょうか。

[yokoazu]

ちなみに全て処理は正常に完了しています。何行でも正しく取り込みされました。
ですが最後にエラー400と表示されます。

[tatsu99]

すみません誤解を与えてしまいました。どの行かというのは、マクロのどの行かという意味です。
例として
Public Function GetExcelData(ByVal FilePath As String, ByVal SheetNo As String) As Variantの
Set ws = wb.Worksheets(SheetNo)
の行でエラーが発生してます。・・・・・というような返信を期待していました。

＞tatsuさんが正常に処理できたという事はコード以外の問題も考えられるのでしょうか。
その可能性もありますが、マクロを修正すれば回避できる可能性もあります。
いずれにしろ、まずは、どの行でエラーが発生しているのかを特定する必要があります。

[yokoazu]

すみませんでした。どの行かはデバッグ実行で確認すればわかるのでしょうか。
デバッグで実行したところ10行目のシートを取得部分（以下コード）で実行時エラー1004が表示されました。

Set ws = wb.Worksheets(SheetNo)

初心者すぎてまたトンチンカンな事を言っていたら申し訳ありません・・・

[tatsu99]

Set ws = wb.Worksheets(SheetNo)
このシートがないことが考えられます。10行目のシート名が、仮に"AAA"とすると、
１０行目のブック内に"AAA"のシートがあるはずですが、それがないことが原因です。
エラー発生時、上記の行のSheetNoにマウスをあてると、その内容が表示されます。
それでシート名を確認してください。

[yokoazu]

返信遅く申し訳ございません。原因がわかりました。ご指摘頂いたとおりでした。
質問時に張り付けた「Book②.xlsm」の画像A列に何も記載していない行のところもNoを入れていた事が原因でした。（貼り付けた画像で言うと、４行目が空欄なのにA列に「3」と入力していた事がエラーの原因）

空欄行はA列（No）も空欄にしたところエラーが解消されました。マウスをあてるとその内容が表示される事も知らず色々と勉強になりました。こんなに早く的確に回答を頂ける事に驚いています。丁寧にご指導頂き大変感謝しております。