Excel 2016 VBA仅打开其他工作簿时运行极慢问题求助

我在Excel 2016工作簿中编写了宏ma_neu，该宏从SQL Server获取数据并写入“MA-Rohdaten”工作表，随后刷新“MA-Auswertung”工作表中的数据透视表。宏代码如下：

Option Explicit

Public Sub enableAll(Optional ByVal opt As Boolean = True)

With Application
    .Calculation = IIf(opt, xlCalculationAutomatic, xlCalculationManual)
    .EnableEvents = opt
    .DisplayAlerts = opt
    .ScreenUpdating = opt
    .DisplayStatusBar = opt
End With

Dim wb As Workbook, ws As Worksheet

For Each wb In Workbooks
    For Each ws In wb.Worksheets 'this line was changed after BigBens comments below
               'prior to the change it was: For Each ws In Worksheets
        ws.EnableCalculation = opt
        ws.EnableFormatConditionsCalculation = opt
    Next
Next

End Sub


Sub ma_neu(maSOLL As String, ab As Date)

enableAll False

Dim i As Long
Dim j As Long
Dim k As Long
Dim m As Long
        
Dim daten As Variant

Dim objConn As Object
Dim objRecSet As Object
Dim strSQL As String

With Sheets("MA-Rohdaten")
    'Aufräumen
    i = 6
    While (.Cells(i, 3) <> "")
        i = i + 1
    Wend
    Range(.Cells(6, 3), .Cells(i, 12)).Clear
End With

On Error GoTo NoDATA:

Set objConn = CreateObject("ADODB.Connection")
objConn.Open "Driver={SQL Server};Server=s-app\servername;Database=dbname;Trusted Connection=yes;User Id=customReader;Password=XXXXX;"
Set objRecSet = CreateObject("ADODB.RecordSet")

strSQL = "SELECT dbname.ma.lang, dbname.nachschl.kurz, dbname.zeit.datum, " & _
    "dbname.pr.kurz, dbname.auftraege.kurz, dbname.auftraege.lang, dbname.updata.kurz, " & _
    "dbname.tk.kurz, dbname.zeit.bemerkung, dbname.zeit.dauer FROM dbname.zeit " & _
    "INNER JOIN dbname.ma ON dbname.zeit.maid = dbname.ma.id " & _
    "INNER JOIN dbname.nachschl ON dbname.ma.gruppe = dbname.nachschl.nachschlid " & _
    "INNER JOIN dbname.pr ON dbname.zeit.prid = dbname.pr.id " & _
    "INNER JOIN dbname.auftraege ON dbname.zeit.auftragid = dbname.auftraege.id " & _
    "INNER JOIN dbname.tk ON dbname.zeit.tkid = dbname.tk.id " & _
    "INNER JOIN dbname.updata ON dbname.zeit.upid = dbname.updata.id " & _
    "WHERE dbname.ma.kurz = '" & maSOLL & "' " & _
    "AND dbname.zeit.datum >= '" & Format(ab, "yyyy-mm-dd") & "' " & _
    "ORDER BY dbname.auftraege.kurz, dbname.zeit.datum, dbname.tk.kurz, dbname.updata.kurz ASC;"

objRecSet.Open strSQL, objConn
daten = objRecSet.GetRows
objRecSet.Close
    
If Not IsEmpty(daten) Then
    With Sheets("MA-Rohdaten")
        i = 6
        For k = LBound(daten, 2) To UBound(daten, 2)
            For m = LBound(daten, 1) To UBound(daten, 1)
                .Cells(i + k, 3 + m) = daten(m, k)
            Next m
        Next k
        .Cells.WrapText = False
    End With
End If

With Sheets("MA-Auswertung")
    .PivotTables("PivotTable1").ChangePivotCache ActiveWorkbook.PivotCaches.Create _
    (SourceType:=xlDatabase, SourceData:="MA-Rohdaten!R5C3:R" & k + 6 - 1 & "C12", Version:=6)
    .PivotTables("PivotTable1").PivotCache.Refresh

    i = 3
    While (.Cells(4, i)) = ""
        i = i + 1
    Wend
    .Cells(4, i).Group Start:=True, End:=True, Periods:=Array(False, False, False, False, True, False, True)
    .Select
    .Cells(1, 1).Select
End With

enableAll
    
Exit Sub
NoData:
On Error GoTo 0
MsgBox "Komme nicht auf den SQL Server"

enableAll

End Sub

为加速VBA执行，我编写了enableAll子过程，在ma_neu开始时关闭Excel的自动计算、事件处理、屏幕更新等额外开销，执行结束后恢复这些设置。单独运行该宏耗时约0.5秒，但打开另一个无任何关联的小型工作簿（仅包含4000个数值单元格和2000个简单求和公式，共6000个单元格）时，宏的执行时间骤增至5秒以上。尽管已将Application.Calculation设置为手动并关闭事件，仍怀疑其他工作簿被重复计算。请问如何让Excel仅聚焦当前工作簿？该现象的原因是什么？

1. enableAll遍历所有工作簿的冗余操作：当前enableAll会循环遍历Excel中所有打开的工作簿及其工作表，修改ws.EnableCalculation和ws.EnableFormatConditionsCalculation属性。当有其他工作簿打开时，这个循环会产生额外性能开销，尤其是其他工作簿包含大量公式时，修改这些属性可能触发隐式的计算检查或状态更新。
2. 全局计算设置的间接影响：虽然Application.Calculation设为手动，但其他工作簿的工作表计算状态被修改后，在宏结束恢复设置时，可能触发这些工作簿的批量计算，导致整体执行时间变长。
3. 未明确限定操作范围：宏中部分代码（如Sheets("MA-Rohdaten")）未明确指定所属工作簿，依赖Excel的活动工作簿上下文，当有多个工作簿打开时，可能存在隐式的上下文切换开销。

1. 修改enableAll仅针对当前工作簿操作 #

将遍历所有工作簿的逻辑改为只处理宏所在的当前工作簿，避免干扰其他工作簿：

Public Sub enableAll(Optional ByVal opt As Boolean = True)
    Dim wb As Workbook
    Dim ws As Worksheet
    
    Set wb = ThisWorkbook '明确指向宏所在的工作簿
    
    With Application
        .Calculation = IIf(opt, xlCalculationAutomatic, xlCalculationManual)
        .EnableEvents = opt
        .DisplayAlerts = opt
        .ScreenUpdating = opt
        .DisplayStatusBar = opt
    End With

    '仅遍历当前工作簿的工作表
    For Each ws In wb.Worksheets
        ws.EnableCalculation = opt
        ws.EnableFormatConditionsCalculation = opt
    Next ws
End Sub

2. 明确限定工作表所属工作簿 #

在宏中所有操作工作表的代码前，加上ThisWorkbook限定，避免依赖活动工作簿：

'原代码：With Sheets("MA-Rohdaten")
改为：With ThisWorkbook.Sheets("MA-Rohdaten")

'原代码：With Sheets("MA-Auswertung")
改为：With ThisWorkbook.Sheets("MA-Auswertung")

3. 优化数据清理逻辑 #

原代码用循环查找空行的方式效率较低，可改为使用UsedRange或直接定位最后一行：

With ThisWorkbook.Sheets("MA-Rohdaten")
    'Aufräumen
    Dim lastRow As Long
    lastRow = .Cells(.Rows.Count, 3).End(xlUp).Row
    If lastRow >= 6 Then
        .Range(.Cells(6, 3), .Cells(lastRow, 12)).Clear
    End If
End With

4. 避免不必要的工作表选择操作 #

宏末尾的.Select和.Cells(1,1).Select属于冗余操作，会增加屏幕更新的隐性开销，可直接删除：

'删除以下两行：
.Select
.Cells(1, 1).Select

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