vbscript VBA用于遍历文件和文件夹，并提示用户选择文件/文件夹。包括一个例子。

Posted 2021-05-22

Private progress As Integer, progressFileCount As Integer

'start here
Sub doStuff()
    
    Dim path As String
    
    'get the path to the folder containing all the files
    MsgBox "Select the folder containing all the files."
    path = GetFolderName
    If path = "" Then 'user clicked Cancel
        Exit Sub
    End If
    
    progressFileCount = GetFileCount(path)
    progress = 0
    
    Application.ScreenUpdating = False  'so you don't see each file opening and closing
    Application.DisplayStatusBar = True 'show the status bar at the bottom of the window
    
    processFolder path
    
    Application.StatusBar = False 'clear the status bar
    Application.ScreenUpdating = True
    
End Sub

Private Sub processFile(wb as Workbook, filename as String)
    
    'the `wb` parameter references the workbook
    '...
    
End Sub

Private Sub processFolder(thePath)
    
    Dim wb As Workbook
    Dim theFile As String
    Dim theDir As String
    Dim sDirList As String: sDirList = ""
    Dim arDirList() As String
    Dim i As Integer: i = 1
    
    If thePath <> "" Then
        
        On Error Resume Next
        ChangeDirectory thePath
        If Err > 0 Then 'not a folder (just a file with no extension)
            Exit Sub   'skip it
        End If
        On Error GoTo 0
        
        theFile = Dir("*.xls*")
        Do While theFile <> ""  'for each workbook in this folder
            Set wb = Workbooks.Open(thePath & "\" & theFile)
            processFile wb, theFile   'process the file
            wb.Close
            
            Call updateProgress 'update the progress in the status bar
            
            theFile = Dir
        Loop
        
        theDir = Dir("*.", vbDirectory) 'subdirectories
        Do While theDir <> ""   'for each subdirectory
            If theDir <> "." And theDir <> ".." Then sDirList = sDirList & ";" & theDir 'save the directory name
            theDir = Dir
        Loop
        
        arDirList = Split(sDirList, ";")    'convert the directory name list to an array
        Do While i <= UBound(arDirList) 'for each subdirectory
            processFolder (thePath & "\" & arDirList(i))    'process the files & directories in that folder
            i = i + 1
        Loop
        
    End If
    
End Sub

'counts the number of Excel files in a folder and its subfolders
Private Function GetFileCount(thePath)
    
    Dim theFile As String
    Dim theDir As String
    Dim sDirList As String: sDirList = ""
    Dim arDirList() As String
    Dim i As Integer: i = 1
    
    GetFileCount = 0
    
    If thePath <> "" Then
        
        On Error Resume Next
        ChangeDirectory thePath
        If Err > 0 Then 'not a folder (just a file with no extension)
            Exit Function   'skip it
        End If
        On Error GoTo 0
        
        theFile = Dir("*.xls*")
        Do While theFile <> ""  'for each workbook in this folder
            GetFileCount = GetFileCount + 1
            theFile = Dir
        Loop
        
        theDir = Dir("*.", vbDirectory)
        Do While theDir <> ""   'for each subdirectory
            If theDir <> "." And theDir <> ".." Then sDirList = sDirList & ";" & theDir 'add it to the list
            theDir = Dir
        Loop
        arDirList = Split(sDirList, ";")    'convert the subdirectory list to an array
        Do While i <= UBound(arDirList) 'for each subdirectory
            GetFileCount = GetFileCount + GetFileCount(thePath & "\" & arDirList(i))   'recurse
            i = i + 1
        Loop
        
    End If
    
End Function

Private Sub updateProgress()
    
    progress = progress + 1
    
    Application.StatusBar = "Processing files... " & Round(100 * progress / progressFileCount) & "% complete."
    
End Sub

'requires reference to Microsoft Office 14.0 Object Library

'prompts the user for a folder
'see http://www.vbaexpress.com/kb/getarticle.php?kb_id=896
Private Function GetFolderName(Optional OpenAt As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = OpenAt
        .Show
        If .SelectedItems.Count = 0 Then Exit Function
        GetFolderName = .SelectedItems(1)
    End With
End Function

'prompts the user for a file
Private Function GetFileName(Optional OpenAt As String) As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = OpenAt
        .Show
        If .SelectedItems.Count = 0 Then Exit Function
        GetFileName = .SelectedItems(1)
    End With
End Function

'changes the current directory to the specified path
'see https://www.mrexcel.com/forum/excel-questions/70668-help-chdir-please.html#post338674
Private Sub ChangeDirectory(path)
    Dim oFS As Object
    On Error Resume Next
    ChDir path
    If Err > 0 Then
        On Error GoTo 0
        Set oFS = CreateObject("Scripting.FileSystemObject")
        ChDrive oFS.GetDriveName(path)
        ChDir path
        Set oFS = Nothing
    End If
    On Error GoTo 0
End Sub