特定フォルダ内Excelの自動転記

Question

実現したいこと

●指定年度範囲のフォルダを探し、ファルダ内Excel内容を集計表へ転記
＜条件＞
・集計表Excelの指定年度で合致したフォルダ内のExcelから、集計表の10行目以降に転記。
1ファイル1行転記
・指定年度：集計表ExcelのB2からB3
・集計表フォルダパス_C:\Users\xxxxxx.yyy\Desktop\共通\50_VBA\フォルダ検索処理\集計表
・検索フォルダパス_C:\Users\xxxxxx.yyy\Desktop\共通\50_VBA\フォルダ検索処理\転記元
※xxxxxx.yyyは個人情報になる為xyで表示しました。
・検索条件：以下図1の通り、集計表yyyyと検索フォルダ名の6桁目から9桁のyyyyで照合し合致フォルダ内Excelの処理→2020と2020で合致
パターン①：B2が2020でB3が空白の場合、2065-2020年度フォルダ内Excelのみ処理
パターン②：B2が2020でB3が2021の場合、2065-2020年度、2165-2021年度フォルダ内Excelを処理
※2065-2020年度フォルダの桁数は変わらず、年度毎に手動で増えていく。
例.2023の場合、2365-2023年のように
●検索条件_図1

●集計表ファイル構成

●集計表ファイル（VBA実行ファイル）

●検索フォルダ構成

●検索ファイル構成※検索フォルダの2265-2022年度フォルダの中身

●検索ファイル中身※ファイルフォーマットは全て同じ

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

・指定年度範囲のフォルダを探すコードが分からなく相談させていただきました。
・現コードはコード内で対象フォルダパスを指定してでの処理になってしまっています。

エラーメッセージ

該当のソースコード

Sub 転記処理()

Const source As String = "C:\Users\z09071.SWN\Desktop\共通\50_VBA\フォルダ検索処理\転記元\2065-2020年度"
Const copy As String = "C:\Users\z09071.SWN\Desktop\共通\50_VBA\フォルダ検索処理\集計表"
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Worksheets("集計表")
Dim fs As FileSystemObject
Set fs = New Scripting.FileSystemObject
Dim myfolder As Folder
Set myfolder = fs.GetFolder("C:\Users\z09071.SWN\Desktop\共通\50_VBA\フォルダ検索処理\転記元\2065-2020年度")

If ws1.FilterMode = True Then '集計表ソートクリア条件式
    ws1.ShowAllData
End If
ws1.Rows("10:" & Rows.Count).ClearContents 'データ削除

Dim myfile As File 'フォルダ内ファイル繰返し処理
For Each myfile In myfolder.Files
    If fs.GetExtensionName(myfile) = "xlsx" Then '拡張子xlsxのファイルを対象に処理を行う
            Dim wb As Workbook
            Set wb = Workbooks.Open(Filename:=myfile)
            Dim ws2 As Worksheet
            Set ws2 = wb.Worksheets(1)
            ws1.Cells(10 + i, 1).Value = ws2.Cells(1, 2).Value
            ws1.Cells(10 + i, 2).Value = ws2.Cells(2, 2).Value
            ws1.Cells(10 + i, 3).Value = ws2.Cells(3, 2).Value
            ws1.Cells(10 + i, 4).Value = ws1.Cells(10 + i, 2).Value * ws1.Cells(10 + i, 3).Value
            ws1.Cells(10 + i, 5).Value = ws2.Cells(4, 2).Value
            i = i + 1
            
            wb.Close
            Set ws2 = Nothing
            Set wb = Nothing
        End If
    Next
        Set myfolder = Nothing
    Set fs = Nothing
            
End Sub

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

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

Answer 1

下記でどうでしょう。

Public Sub Sample()
    Dim ws1 As Worksheet
    Set ws1 = ThisWorkbook.Worksheets("集計表")

    Dim fromYear As Long, toYear As Long
    fromYear = Val(ws1.Range("B2"))
    toYear = Val(ws1.Range("B3"))
    If toYear = 0 Then toYear = fromYear
    
    Dim i As Long, folderName As String
    For i = fromYear To toYear
        folderName = Right(i, 2) & "65-" & i & "年度"
        Debug.Print folderName 'フォルダー名確認用
        
        
        'フォルダ内ファイル繰返し処理
        '略
    
    Next
End Sub

Comments

[jabe]

コード作成ありがとうございます。
問題なく動作できました。助かりました。
・文字の切出し、結合を用いてfor文で対象フォルダを探す点が勉強になりました。
folderName = Right(i, 2) & "65-" & i & "年度"
また、以下のようにendifで閉じなくてもif文は動作するんですね。
If toYear = 0 Then toYear = fromYear

[hatena19]

If文は1行で記述する場合は end If は不要ですね。

[jabe]

回答ありがとうございます。
なるほどです。

[jabe]

もう一点教えて下さい。
以下コードでfromYearとtoYearをsetで格納しましたら、オブジェクトエラーが出てしまいました。
理由は何になるのでしょうか？set fromYear = Val(ws1.Range("B2"))
Dim fromYear As Long, toYear As Long
fromYear = Val(ws1.Range("B2"))
toYear = Val(ws1.Range("B3"))