temp3

後ほど

Sub 一覧表作成()
    Dim arrSubFolders() As String
    Dim targetPath As String
    Dim i As Integer
    
    With Sheets("Sheet2")
        .Select
        .Range("B2") = "フォルダ名"
        .Range("C2") = "ファイル名"
        .Range("D2") = "更新日"
        .Range("E2") = "フルパス"
    End With
    
    targetPath = "C:\Users\cryst\OneDrive\デスクトップ\できるExcelグラフ"
    'サブフォルダを取得
    arrSubFolders = getSubFolderArray(targetPath)
    
    For i = 0 To UBound(arrSubFolders)
        'サブフォルダ内のワイルを取得
        Call MakeList(targetPath, arrSubFolders(i))
    Next
    
End Sub

Sub MakeList(strParentPath As String, strSubFolderName As String)
    Dim arrFiles() As String
    Dim lastRow As Integer
    Dim i As Integer
    Dim j As Integer
    Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
    Dim f As Object
    Dim strFullPath As String
    Dim d As Date
    
    arrFiles = getFileArray(strParentPath & "\" & strSubFolderName)
    
    With Sheets("Sheet2")
        .Select
        lastRow = .Cells(Rows.Count, 2).End(xlUp).Row
        j = lastRow + 1
        
        For i = 0 To UBound(arrFiles)
            strFullPath = strParentPath & "\" & strSubFolderName & "\" & arrFiles(i)
            Set f = FSO.GetFile(strFullPath)
            d = f.DateLastModified
            .Cells(j, 2) = strSubFolderName
            .Cells(j, 3) = arrFiles(i)
            .Cells(j, 4) = d
            .Cells(j, 5) = strFullPath
            j = j + 1
        Next
    End With
        
End Sub

Function getSubFolderArray(strFolderPath As String) As String()
'----------------------------------------------------------
'機能  ：指定したフォルダパスのフォルダ内のサブフォルダを取得する
'引数1 ：対象フォルダパス
'戻り値 :取得したサブフォルダのパスを配列で返す
'----------------------------------------------------------

Dim FSO As Object
Dim subFolders As Object
Dim tmpFolder As Object
Dim intFolderCount As Integer
Dim arrayFolders() As String
Dim i As Integer

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set subFolders = FSO.GetFolder(strFolderPath).subFolders
    
    intFolderCount = subFolders.Count
    
    i = 0
    'ReDim arrayFolders(intFolderCount - 1)
    
    With FSO.GetFolder(strFolderPath)
    
        For Each tmpFolder In .subFolders
            If CheckStr(tmpFolder.Name) Then
                ReDim Preserve arrayFolders(i)
                arrayFolders(i) = tmpFolder.Name
                i = i + 1
            
            End If
        Next
        
    End With
    
    getSubFolderArray = arrayFolders()

End Function

Sub test()
Dim result As Boolean

result = CheckStr("第８章")

MsgBox result

End Sub

Function CheckStr(strFolederName As String) As Boolean
    Dim Reg As Object
    Set Reg = CreateObject("VBScript.RegExp")
     With Reg
        .Pattern = ".+[0-2０-２].+"
        CheckStr = .test(strFolederName)
     End With
End Function

Function getFileArray(strFolderPath As String) As String()
'----------------------------------------------------------
'機能  ：指定したフォルダパスのフォルダ内のファイルを取得する
'引数1 ：対象フォルダパス
'戻り値 :取得したファイル名を配列で返す
'----------------------------------------------------------

Dim FSO As Object
Dim tmpFile As Object
Dim objFiles As Object
Dim intFilesCount
Dim arrayFiles() As String
Dim i As Integer

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set objFiles = FSO.GetFolder(strFolderPath).Files
    intFilesCount = objFiles.Count
    
    i = 0
    ReDim arrayFiles(intFilesCount - 1)
    
    With FSO.GetFolder(strFolderPath)
        For Each tmpFile In .Files
            arrayFiles(i) = tmpFile.Name
            i = i + 1
        Next
    End With
    getFileArray = arrayFiles()
End Function