ネット情報を頼りに継ぎ足しながらどうにかコードを作成しました。
エラーは出ませんが、修正した方が良い所があると思われます。
改善すべき箇所を指摘ください。
Sub test()
'サブフォルダー内の映画名を取得
' 指定フォルダーのパスを設定
Dim TopFolder As String
TopFolder = "G:\映画別"
'「Microsoft Scripting Runtime（実行時バインディング）
' 指定フォルダー内のサブフォルダーを取得
Dim subfolder As Object
Set subfolder = CreateObject("Scripting.FileSystemObject").GetFolder(TopFolder)
' サブフォルダー名を表示
Dim SerchfolderPath As String
Dim SerchfolderName() As String
Dim j As Long
' サブフォルダーの数を取得
Dim subfolderCount As Long
subfolderCount = subfolder.SubFolders.Count
' 配列をサブフォルダーの数に合わせてリサイズ
ReDim SerchfolderName(1 To subfolderCount)
j = 1
For Each subfolder In subfolder.SubFolders
SerchfolderPath = subfolder.Path
SerchfolderName(j) = subfolder.Name
j = j + 1
Next subfolder
'----------------------------------------------------------
'指定フォルダー内のファイル名を取得（階層フォルダーを含めたファイルリスト : 再帰処理）
Dim aryFile() As String 'ファイル名を格納する動的配列
Dim cnt As Long '検出ファイルのカウント
Const pathFolder As String = "L:\#おこのみ"
cnt = 0
f_getFileArray pathFolder, aryFile, cnt
Dim i As Long, ii As Long
ii = 1
For i = 2 To cnt
' anyFile()の中にSerchfolderName()と同じ文字列が存在するかチェック
For j = 1 To subfolderCount
If InStr(1, aryFile(ii), SerchfolderName(j), vbTextCompare) > 0 Then
' 同じ文字列が存在する場合、シートに書き出す
Cells(i, 1) = SerchfolderName(j)
Cells(i, 2) = aryFile(ii)
Exit For
End If
Next j
ii = ii + 1
Next i
'空白行のみを削除(A1000は適当）
Range("A2:A1000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Function f_getFileArray(aPath As String, aryFile() As String, cnt As Long)
'要参照設定: Microsoft Scripting Runtime
Dim oFS As New FileSystemObject
Dim oFile As File
Dim oFolder As Folder
'サブフォルダーの処理: 再帰呼び出し
For Each oFolder In oFS.GetFolder(aPath).SubFolders
f_getFileArray oFolder.Path, aryFile, cnt
Next
'ファイルの処理: サイズ1MB以上のファイルを配列に追加
For Each oFile In oFS.GetFolder(aPath).Files
If oFile.Size > 1000000 Then
cnt = cnt + 1
ReDim Preserve aryFile(1 To cnt)
aryFile(cnt) = oFile.Path
End If
Next
Set oFile = Nothing
Set oFolder = Nothing
Set oFS = Nothing
End Function
