シンプルな要件：Windows 環境で VBS/VBA を使用して特定のディレクトリ内のすべてのファイルを抽出し、現在のディレクトリのすべてのサブディレクトリを走査する必要があります。各サブディレクトリには、ファイル名が重複する場合や空のディレクトリが存在する場合があります。
VBS コードの実装
' 走査するディレクトリのパス
dim strDirPath = "c:\dir"
' ディレクトリの走査
Private Sub FileTree(strPath)
Set obFso = CreateObject("Scripting.FileSystemObject")
If obFso.FolderExists(strPath) Then
Set obFolder = obFso.GetFolder(strPath)
' 現在のディレクトリのすべてのサブディレクトリを走査し、再帰的に呼び出す
Set obSubFolders = obFolder.SubFolders
For Each obSubFolder In obSubFolders
Call FileTree(obSubFolder.Path & "")
Next
' 現在のディレクトリを除外する
If strPath = Trim(strDirPath) Then
Exit Sub
End If
' 現在のディレクトリのすべてのファイルを走査する
Set obFiles = obFolder.Files
For Each obFile In obFiles
Call ExcuteFolderConcentrate(obFile.Path & "")
Next
Else
MsgBox "無効なパスです"
Exit Sub
End If
End Sub
' ファイルの収集操作
Private Sub ExcuteFolderConcentrate(strPath)
Set obFso = CreateObject("Scripting.FileSystemObject")
If obFso.FileExists(strPath) Then
fullPath = Trim(strDirPath) & "\"
' ディレクトリの階層に基づいて新しいファイル名を設定する
newFileName = Replace(Right(strPath, Len(strPath) - Len(fullPath)), "\", "_")
' 重複するファイルの名前を変更する
If obFso.FileExists(fullPath & newFileName) Then
Call obFso.copyFile(strPath, fullPath & newFileName & ".duplicate")
Else
Call obFso.copyFile(strPath, fullPath & newFileName)
End If
End If
End Sub
' ディレクトリ全体を走査してファイルの収集を完了する
FileTree (strDirPath)
' ディレクトリフォルダを再度開く
CreateObject("Shell.Application").Explore strDirPath