从另一工作簿批量运行主宏工作簿中的多宏任务

我有一个包含多个宏的Master Macro工作簿，其中的Generate Separate Files工作表设有下拉选择框和宏运行按钮。选中下拉值后点击按钮，工作簿会以选中值为名另存，并过滤各工作表数据保留对应值的数据。目前需要手动重复操作25次，希望创建新宏工作簿，实现以下自动流程：

• 自动打开该主宏工作簿
• 遍历下拉选择框的所有25个值
• 自动运行对应宏批量生成文件

现有待优化代码 #

Sub Runmasterfilemacros ()
Dim wb1 as workbook
Dim wb2 as workbook
Dim sht1 as worksheet
Dim sht2 as worksheet   
Dim myrange as Range        

Set wb1 = ThisWorkbook
Set wb2 = ThisWorkbook.Sheets("Run Macro").Range("A2").Value
' This Workbook Run Macro Range A2 value = "c:\macrofiles\Master Macro File.xlsm"
Set sht1 = ThisWorkbook.Sheets("Run Marco")
Set sht2 = Workbooks("Master Macro File").Sheets("Generate Separate Files")
Set myrange = Workbooks("Master Macro File").Sheets("Generate Separate Files").Range("A11").Value

wb2.Select
sht2.select
myrange.select
myrange.value  = "File1"
Application.Run "File1Macro"
'wait for the macro to run and the workbook to get saved as File1 then run another macro

wb1.Activate

wb2.Select
sht2.select
myrange.select
myrange.value  = "File2"
Application.Run "File2Macro"
'wait for the macro to run and the workbook to get saved as File2 then run another macro

wb2.Select
sht2.select
myrange.select
myrange.value  = "File3"
Application.Run "File3Macro"
'wait for the macro to run and the workbook to get saved as File3 then run another macro

wb2.Select
sht2.select
myrange.select
myrange.value  = "File4"
Application.Run "File4Macro"
'wait for the macro to run and the workbook to get saved as File4 then run another macro

wb2.Select
sht2.select
myrange.select
myrange.value  = "File5"
Application.Run "File5Macro"
'wait for the macro to run and the workbook to get saved as File5 then run another macro

'This needs to run for all the values which are in the validation dropdown of myrange .i.e. 25 files
End Sub

优化后的代码 #

Sub BatchRunMasterMacros()
    Dim wbControl As Workbook
    Dim wbMaster As Workbook
    Dim shtControl As Worksheet
    Dim shtMaster As Worksheet
    Dim targetCell As Range
    Dim dropdownValues As Variant
    Dim i As Integer
    Dim masterFilePath As String
    Dim macroName As String
    
    ' 初始化控制工作簿和工作表
    Set wbControl = ThisWorkbook
    Set shtControl = wbControl.Sheets("Run Macro")
    masterFilePath = shtControl.Range("A2").Value ' 主宏工作簿路径
    
    ' 打开主宏工作簿（只读模式避免冲突）
    On Error Resume Next
    Set wbMaster = Workbooks.Open(masterFilePath, ReadOnly:=False)
    On Error GoTo 0
    If wbMaster Is Nothing Then
        MsgBox "无法打开主宏工作簿，请检查路径是否正确！", vbCritical
        Exit Sub
    End If
    
    ' 初始化主宏工作簿的目标工作表和下拉单元格
    Set shtMaster = wbMaster.Sheets("Generate Separate Files")
    Set targetCell = shtMaster.Range("A11")
    
    ' 提取下拉选择框的所有选项值
    dropdownValues = GetDataValidationValues(targetCell)
    If IsEmpty(dropdownValues) Then
        MsgBox "未找到下拉选择框的选项值！", vbExclamation
        wbMaster.Close SaveChanges:=False
        Exit Sub
    End If
    
    ' 关闭屏幕更新提升运行速度
    Application.ScreenUpdating = False
    
    ' 遍历所有下拉选项
    For i = LBound(dropdownValues) To UBound(dropdownValues)
        ' 设置下拉单元格值
        targetCell.Value = dropdownValues(i)
        ' 构造对应宏名称（假设宏命名规则为"[值]Macro"，如File1Macro）
        macroName = dropdownValues(i) & "Macro"
        
        ' 运行对应宏
        On Error Resume Next
        Application.Run "'" & wbMaster.Name & "'!" & macroName
        If Err.Number <> 0 Then
            MsgBox "运行宏 " & macroName & " 时出错：" & Err.Description, vbExclamation
            Err.Clear
        End If
        On Error GoTo 0
    Next i
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    
    ' 关闭主宏工作簿（不保存，因为生成文件的操作已独立完成）
    wbMaster.Close SaveChanges:=False
    MsgBox "批量生成文件完成！", vbInformation
End Sub

' 辅助函数：获取单元格数据验证的所有选项值
Function GetDataValidationValues(targetCell As Range) As Variant
    Dim validationFormula As String
    Dim sourceRange As Range
    Dim valuesArray As Variant
    
    ' 检查单元格是否有数据验证
    If Not targetCell.Validation.Type = xlValidateList Then
        GetDataValidationValues = Empty
        Exit Function
    End If
    
    ' 获取数据验证的源公式
    validationFormula = targetCell.Validation.Formula1
    ' 移除公式开头的"="
    validationFormula = Mid(validationFormula, 2)
    
    ' 获取源范围并转换为数组
    On Error Resume Next
    Set sourceRange = Range(validationFormula)
    On Error GoTo 0
    If Not sourceRange Is Nothing Then
        valuesArray = sourceRange.Value
        ' 如果是单列范围，转换为一维数组
        If UBound(valuesArray, 2) = 1 Then
            valuesArray = Application.Transpose(valuesArray)
        End If
        GetDataValidationValues = valuesArray
    Else
        ' 如果源是直接输入的逗号分隔值
        GetDataValidationValues = Split(validationFormula, ",")
    End If
End Function

优化说明 #

• 修正对象初始化错误：使用Workbooks.Open正确打开主宏工作簿，替代原代码中直接赋值路径给Workbook对象的错误写法
• 自动提取下拉选项：通过辅助函数GetDataValidationValues自动获取下拉框的所有25个选项，无需硬编码
• 循环批量处理：用For循环遍历所有选项，替代重复的手动代码块
• 避免Select/Activate：直接操作单元格和工作簿对象，提升代码运行效率与稳定性
• 错误处理机制：添加路径检查、宏运行错误捕获，防止流程中断
• 性能优化：关闭屏幕更新减少运行时的界面闪烁

内容的提问来源于stack exchange，提问作者adifadipe