VBA代码运行耗时10+分钟及子宏调用失效问题求助

问题1：批量调用子宏无法复制数据到Winners Hidden工作表 #

故障原因 #

• Winner_Copied宏未禁用屏幕刷新，批量调用时工作表可见性切换的时序冲突导致复制粘贴失效
• 依赖Select/Activate操作，这种方式对当前激活的工作表状态高度敏感，批量调用时容易出现状态不一致
• 宏内存在重复的复制粘贴冗余代码，进一步干扰执行逻辑

修复措施 #

1. 在Winner_Copied中添加屏幕刷新、事件触发和计算模式的控制
2. 移除Select/Activate，直接引用工作表对象
3. 删除冗余的重复复制代码

问题2：代码运行耗时超10分钟的优化方案 #

原代码性能瓶颈主要来自：大量Select/Activate操作、频繁的工作表可见性切换、低效的复制粘贴、未禁用Excel后台功能。优化方向如下：

• 禁用后台功能：运行代码时关闭屏幕刷新、事件触发和自动计算，完成后恢复
• 移除Select/Activate：直接通过工作表和单元格对象引用操作，消除界面切换开销
• 替换复制粘贴：使用单元格值直接赋值，比复制粘贴快数倍
• 合并冗余操作：删除重复的复制逻辑，减少不必要的工作表可见性切换
• 统一状态管理：在主调用宏CallerMacro中统一控制Excel状态，避免子宏重复操作

优化后的完整代码 #

Sub Access_Tabel()
    Dim srcSheet As Worksheet, destSheet As Worksheet
    Dim lastRow As Long
    
    ' 禁用Excel后台功能以提速
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    Set srcSheet = ThisWorkbook.Sheets("Access Table")
    Set destSheet = ThisWorkbook.Sheets("Information Sheet Hidden")
    
    ' 复制Access Table数据到目标工作表
    lastRow = srcSheet.Cells(srcSheet.Rows.Count, "A").End(xlUp).Row
    srcSheet.Range("A2:A" & lastRow).Copy destSheet.Range("A2")
    
    ' 应用筛选规则
    destSheet.ListObjects("Information_Hidden_Sheet").Range.AutoFilter _
        Field:=5, _
        Criteria1:=Array("1", "10", "11", "12", "13", "14", "15", "16", "17", "19", "2", "20", _
                        "21", "22", "27", "3", "31", "4", "5", "54", "6", "7", "8", "9", "94"), _
        Operator:=xlFilterValues
    
    destSheet.Visible = False
    
    ' 恢复Excel默认设置
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

Sub Names_Repeated()
    Dim infoSheet As Worksheet, destSheet As Worksheet
    Dim lastRowE As Long, lastRowB As Long
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    Set infoSheet = ThisWorkbook.Sheets("Information Sheet Hidden")
    Set destSheet = ThisWorkbook.Sheets("Names Repeated")
    
    infoSheet.Visible = True
    
    ' 复制E列数据到A列（合并原代码中E2/E3的重复操作）
    lastRowE = infoSheet.Cells(infoSheet.Rows.Count, "E").End(xlUp).Row
    destSheet.Range("A2:A" & lastRowE - 1).Value = infoSheet.Range("E2:E" & lastRowE).Value
    
    ' 复制B列数据到B列
    lastRowB = infoSheet.Cells(infoSheet.Rows.Count, "B").End(xlUp).Row
    destSheet.Range("B2:B" & lastRowB - 1).Value = infoSheet.Range("B2:B" & lastRowB).Value
    
    infoSheet.Visible = False
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

Sub Raffel_Table_Both()
    Dim srcSheet As Worksheet, destSheet As Worksheet
    Dim lastRow As Long
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    Set srcSheet = ThisWorkbook.Sheets("Names Repeated")
    Set destSheet = ThisWorkbook.Sheets("Raffel Table Hidden")
    
    ' 复制D列数据到目标工作表
    lastRow = srcSheet.Cells(srcSheet.Rows.Count, "D").End(xlUp).Row
    destSheet.Range("A2:A" & lastRow - 1).Value = srcSheet.Range("D2:D" & lastRow).Value
    
    destSheet.Visible = False
    
    ' 刷新查询连接
    ThisWorkbook.Connections("Query - Table5").Refresh
    ThisWorkbook.Sheets("Raffel Table Query Hidden2").Visible = False
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

Sub Winner_Copied()
    Dim querySheet As Worksheet, destSheet As Worksheet
    Dim lastRow As Long
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    Set querySheet = ThisWorkbook.Sheets("Raffel Table Query Hidden2")
    Set destSheet = ThisWorkbook.Sheets("Winners Hidden")
    
    querySheet.Visible = True
    
    ' 复制数据到Winners Hidden（移除原代码重复复制逻辑）
    lastRow = querySheet.Cells(querySheet.Rows.Count, "A").End(xlUp).Row
    destSheet.Range("A2:A" & lastRow - 1).Value = querySheet.Range("A2:A" & lastRow).Value
    
    querySheet.Visible = False
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

Sub CallerMacro()
    ' 统一控制Excel状态，避免子宏重复操作
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    Access_Tabel
    Names_Repeated
    Raffel_Table_Both
    Winner_Copied
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

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