別ブックとのセル値転記

Question

前提・実現したいこと

①特定ﾌｫﾙﾀﾞ内の全ﾌｧｲﾙ(転記先)に対して以下条件で照合
条件：ﾌｧｲﾙ名頭文字4桁を抽出し、2021と合致するﾌｧｲﾙを開く
②開いたﾌｧｲﾙのｾﾙB2を変数Aへ格納
③変数Aをﾏｸﾛ実行ﾌｧｲﾙ(転記元)のセルB2へ以下条件で転記
条件：1回目_B2→2回目_B3等

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

・開いたﾌｧｲﾙを都度閉じたのですが、Closeｺｰﾄﾞがｴﾗｰになってしまいます。
・転記先ﾌｧｲﾙに対して、For文がｴﾗｰになってしまいます。
・2021と合致したﾌｧｲﾙ名を検索対象としてるのですが、すべてのﾌｧｲﾙを開かれてしまいます。
※2022,2023ファイルが開かれてしまいます。

該当のソースコード

Sub 別ブックとのセル値転記()
Const TenkiSaki As String = "C:\Users\nakagami\Desktop\サンプル" '転記先ファイルパス
Const TenkiMoto As String = "C:\テスト"            '転記元ファイルパス
Dim TS As String                                                   '転記先ファイル名変数
Dim TM As String                                                    '転記元ファイル名変数
Dim TSname As String
Dim TMname As String
Dim A As Range
Dim lastrow As String
TS = Dir(TenkiSaki & "\2021_集計表.xlsm")          '転記先ファイル名取得
TSname = Left(TS, 4)                                           '転記先ファイル名の年度抽出(ファイル名左から4番目まで)
TM = Dir(TenkiMoto & "*xlsx")                            '転記元ファイル名取得
TMname = Left(TM, 4)                                          '転記元ファイル名の年度抽出(ファイル名左から4番目まで)
Do While TM <> ""                                                '転記元フォルダ内が空白になるまで繰返す
    If TSname = TMname Then                               '年が合致する時は以下処理を実行
        Workbooks.Open (TenkiMoto & "\" & TM)    '対象転記元ファイルを開く
        Set A = Workbooks(TM).Worksheets(1).Cells(2, 2)
        For i = 2 To lastrow
        Workbooks(TS).Worksheets(1).Cells(i, 2) = A
        Next i
        Workbooks.Close (TenkiMoto & "\" & TM)
    End If
    TM = Dir()

Loop

End Sub

補足情報（FW/ツールのバージョンなど）

●転記元フォルダ中身

●転記元ファイル中身
・2021_02.xlxs
![
・2021_02.xlxs

●転記先ファイル中身
・2021_集計表.xlsm

ここにより詳細な情報を記載してください。

Comments

[meg_]

エラーの詳細は分かりませんか？

[jabe]

返信ありがとうございます。
エラーは、引数の数が一致していません。というエラーが発生しました。

Answer 1

このマクロが転記先のファイルに記述されていると勝手に想定して、
以下のように書き換えてみました。

Sub 別ブックとのセル値転記()
    Const TenkiMoto As String = "C:\テスト\"            '転記元ファイルパス
    Dim TSsheet As Worksheet
    Dim TSname As String
    Dim TM As String                                                    '転記元ファイル名変数
    Dim lastRow As Long
    Dim TMbook As Workbook
    
    TSname = Left(ThisWorkbook.Name, 4)                                           '転記先ファイル名の年度抽出(ファイル名左から4番目まで)
    Set TSsheet = ThisWorkbook.Worksheets(1)
    lastRow = TSsheet.Cells(Rows.Count, 2).End(xlUp).Row
    
    TM = Dir(TenkiMoto & TSname & "*.xlsx")                             '転記元ファイル名取得
    Do While TM <> ""                                                '転記元フォルダ内が空白になるまで繰返す
        lastRow = lastRow + 1
        Set TMbook = Workbooks.Open(TenkiMoto & TM)  '対象転記元ファイルを開く
'       TSsheet.Cells(lastRow, 1).Value = TMbook.Worksheets(1).Cells(2, 1).Value
        TSsheet.Cells(lastRow, 2).Value = TMbook.Worksheets(1).Cells(2, 2).Value
        TMbook.Close False
        TM = Dir()
    Loop
End Sub

Comments

[jabe]

親切な回答ありがとうございます。
イメージ通りの動きになりました。
一点質問なのですが、TM = Dir(TenkiMoto & TSname & "*.xlsx")のｺｰﾄﾞで合致条件かどうか判別しているという事でしょうか？
1回目(2021_01)は、TM変数へDir関数取得したﾌｧｲﾙ名を格納
2回目(2021_02)は、TM=Dir()で返されたﾌｧｲﾙ名が格納されたTM変数とDir(TenkiMoto & TSname & "*.xlsx")で取得したﾌｧｲﾙ名を比較し合致
3回目(2022_01)は、TM=Dir()で返されたﾌｧｲﾙ名が格納されたTM変数とDir(TenkiMoto & TSname & "*.xlsx")で取得したﾌｧｲﾙ名を比較し、不一致

[jinoji]

2回目以降のDir()は、1回目の条件を引き継ぎますよね。
元のコードだって *xlsx" の条件に合うもののみを順番に取得する動きだったわけで、
それを "2021*.xlsx" の条件に合うもののみを順番に取得するように変えただけです。

[jinoji]

qnoirさんの回答でお気づきと思いますが、
元のコードだと、そもそも TMname には1回目のファイルでセットしたまま書き換わらないので
意図したとおりに動いていなかったと思います。
それはそれとして、
元のコードがフォルダ内の全Excelファイルでループしていたのを、
Dirの1回目の条件にTSnameも含めることで、2021で始まるExcelファイルだけのループにした感じです。

[jabe]

理解できました。ご丁寧に回答していただきありがとうございました。
再度勉強してきます。

Answer 2

・質問文のコードだと、Whileを繰り返すたびにFor文で同じ位置に書きこんでしまっているので
Whileの外にカウンター（i）を作って、転記先ファイルに書き込むたび、iを１ずつ増やしていけばいいと思います。（そもそもlastrowに対して値が計算されていません）
・Closeの使い方を修正。

Sub 別ブックとのセル値転記()
    Const TenkiSaki As String = "C:\Users\nakagami\Desktop\サンプル" '転記先ファイルパス
    Const TenkiMoto As String = "C:\テスト" '転記元ファイルパス
    Dim TS As String '転記先ファイル名変数
    Dim TM As String '転記元ファイル名変数
    Dim TSname As String
    Dim TMname As String
    Dim A As Range
    Dim lastrow As String
    Dim i as Long
    TS = Dir(TenkiSaki & "\2021_集計表.xlsm") '転記先ファイル名取得
    TSname = Left(TS, 4) '転記先ファイル名の年度抽出(ファイル名左から4番目まで)
    TM = Dir(TenkiMoto & "*xlsx") '転記元ファイル名取得
    TMname = Left(TM, 4) '転記元ファイル名の年度抽出(ファイル名左から4番目まで)

    i = 2
    Do While TM <> "" '転記元フォルダの検索が終わるまで繰り返す
        If TSname = TMname Then '年が合致する時は以下処理を実行
            Workbooks.Open TenkiMoto & "\" & TM    '対象転記元ファイルを開く
            Set A = Workbooks(TM).Worksheets(1).Cells(2, 2)
            Workbooks(TS).Worksheets(1).Cells(i, 2) = A
            i = i + 1
            Workbooks(TM).Close
        End If
        TM = Dir()
        TMname = Left(TM, 4)
    Loop

End Sub

Comments

[jabe]

親切な回答ありがとうございます。
・lastrowについて、ほんとでした値が格納されていませんでした。
・close使い方理解しましたありがとうございます。
●コードを試したのですが、転記元ファイル名すべて転記されてしまいました。
ﾌｧｲﾙ名頭文字4桁の2021ファイルのみ対象にしたいのですが、どう修正すればよろしいでしょうか？

[退会済みユーザー]

修正しました

[jabe]

早速の回答ありがとうございます。
バッチリイメージ通り動きました。
Do while内で”TM = Dir()”と"TMname = Left(TM, 4)"を回し、各ファイルの検索をかけるのですね。理解しました。