VBA实用小程序61： 在文件夹内所有文件中运行宏/在工作簿所有工作表中运行宏

'本程序来自于analystcave.com
Sub RunOnAllFilesInFolder()
    Dim folderName As String
    Dim eApp As Excel.Application
    Dim fileName As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim currWs As Worksheet
    Dim currWb As Workbook
    Dim fDialog As Object
   
    Set fDialog =Application.FileDialog(msoFileDialogFolderPicker)
    Set currWb =ActiveWorkbook
    Set currWs = ActiveSheet
 
    '选择存储所有文件的文件夹
    fDialog.Title = "选择文件夹"
    fDialog.InitialFileName =currWb.Path
    If fDialog.Show = -1 Then
      folderName =fDialog.SelectedItems(1)
    End If
       
    '创建一个单独的不可见的Excel处理进程
    Set eApp = NewExcel.Application
    eApp.Visible = False
   
    '搜索文件夹中的所有文件[使用你的格式例如*.xlsx来代替*.*]
    fileName = Dir(folderName& "\*.*")
    Do While fileName<> ""
        '更新状态栏来指示进度
        Application.StatusBar= "正在处理" & folderName & "\" & fileName
 
        Set wb =eApp.Workbooks.Open(folderName & "\" & fileName)
        '...
        '在这里放置你的代码
        '...
        wb.CloseSaveChanges:=False '关闭打开的工作簿
        Debug.Print "已处理 "& folderName & "\" & fileName
        fileName = Dir()
    Loop
    eApp.Quit
    Set eApp = Nothing
    '清除状态栏并通知宏已完成
    Application.StatusBar =""
    MsgBox "在所有工作簿中都完成了宏执行"
End Sub

'本程序来自于analystcave.com
Dim fileCollection As Collection
Sub TraversePath(path As String)
    Dim currentPath As String
    Dim directory As Variant
    Dim dirCollection AsCollection
    Set dirCollection = NewCollection
   
    currentPath = Dir(path,vbDirectory)
   
    '浏览当前目录
    Do Until currentPath =vbNullString
        Debug.PrintcurrentPath
        If Left(currentPath,1) <> "." And (GetAttr(path & currentPath) And vbDirectory)= vbDirectory Then
            dirCollection.AddcurrentPath
        ElseIfLeft(currentPath, 1) <> "." And (GetAttr(path &currentPath) And vbNormal) = vbNormal Then
           fileCollection.Add path & currentPath
        End If
        currentPath = Dir()
    Loop
   
    '浏览子目录
    For Each directory IndirCollection
        Debug.Print "---子目录: "& directory & "---"
        TraversePath path& directory & "\"
    Next directory
End Sub
 
Sub RunOnAllFilesInSubFolders()
    Dim folderName As String
    Dim eApp As Excel.Application
    Dim fileName As Variant
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim currWs As Worksheet
    Dim currWb As Workbook
    Dim fDialog As Object
   
    Set fDialog =Application.FileDialog(msoFileDialogFolderPicker)
    Set currWb =ActiveWorkbook
    Set currWs = ActiveSheet
 
    '选择存储所有文件的文件夹
    fDialog.Title = "选择文件夹"
    fDialog.InitialFileName =currWb.path
    If fDialog.Show = -1 Then
      folderName =fDialog.SelectedItems(1)
    End If
   
    '创建一个单独的不可见的Excel处理进程
    Set eApp = NewExcel.Application
    eApp.Visible = False
   
    '搜索文件夹中的所有文件[使用你的格式例如*.xlsx来代替*.*]
    Set fileCollection = NewCollection
    TraversePath folderName& "\"
 
    For Each fileName InfileCollection
        '更新状态栏来指示进度
        Application.StatusBar= "正在处理" & fileName
 
 
        Set wb =eApp.Workbooks.Open(fileName)
        '...
        '在这里放置你的代码.
        '...
        wb.CloseSaveChanges:=False '关闭打开的工作簿
        Debug.Print "已处理 "& fileName  '在立即窗口打印已处理
    Next fileName
    eApp.Quit
    Set eApp = Nothing
    '清除状态栏并通知宏已完成
    Application.StatusBar =""
    MsgBox "在所有工作簿中都完成了宏执行"
End Sub

'本程序来自于analystcave.com
Sub RunOnAllWorksheets()
    Dim folderName As String
    Dim eApp AsExcel.Application
    Dim fileName As String
    Dim ws As Worksheet
    Dim currWs As Worksheet
    Dim currWb As Workbook
    Dim fDialog As Object
   
    Set fDialog =Application.FileDialog(msoFileDialogFolderPicker)
    Set currWb =ActiveWorkbook
    Set currWs = ActiveSheet
 
    '搜索文件夹中的所有文件[使用你的格式例如*.xlsx来代替*.*]
    For Each ws In Sheets
        If ws.Name <>currWs.Name Then
            '更新状态栏来指示进度
           Application.StatusBar = "正在处理 "& ws.Name
            '...
            '在这里放置你的代码
            '...
            Debug.Print"已处理" & ws.Name
        End If
    Next ws
    '清除状态栏并通知宏已完成
    Application.StatusBar =""
    MsgBox "在所有工作表中已完成宏执行"
End Sub