Sub ListFilesTest() With Application.FileDialog(msoFileDialogFolderPicker) If .Show Then FolderPath$ = .SelectedItems(1) Else Exit Sub End With If Right(FolderPath, 1) <> "" Then FolderPath = FolderPath & "" filepaths = GetAllFiles(FolderPath) Debug.Print Join(filepaths, vbCr) End Sub Function GetAllFiles(ByVal FolderPath As String, Optional ReturnFiles As Boolean = True) '使用2个字典但无需递归的遍历过程 Dim i As Integer, j As Integer Dim dFolder, dFile, Fso Set dFolder = CreateObject("Scripting.Dictionary") '字典dFolder记录子文件夹的绝对路径名 Set dFile = CreateObject("Scripting.Dictionary") '字典dFile记录文件名 (文件夹和文件分开处理) dFolder(FolderPath) = "" '以当前路径FolderPath作为起始记录,以便开始循环检查 Set Fso = CreateObject("Scripting.FileSystemObject") Do While i < dFolder.Count FolderKeys = dFolder.Keys For Each f In Fso.GetFolder(FolderKeys(i)).Files '遍历该子文件夹中所有文件 (注意仅从新的FolderKeys(i) 开始) j = j + 1 dFile(j) = f.Path Next i = i + 1 For Each fd In Fso.GetFolder(FolderKeys(i - 1)).SubFolders '遍历该文件夹中所有新的子文件夹 dFolder(fd.Path) = " " & fd.Name & "" Next Loop If ReturnFiles = False Then GetAllFiles = dFolder.Keys Else GetAllFiles = dFile.Items End If End Function