VBA宏循环中计算未完成即复制粘贴的问题求助

运行VBA宏时，循环内某一次迭代的计算还没全部完成，就执行了复制粘贴到其他工作表的操作，导致后续粘贴的数据不正确。但宏结束后计算会立即完成，且该次迭代的计算逻辑和前几次没有差异。

我试过用以下代码强制计算完成后再执行复制粘贴：

Do While Not Application.CalculationState = xlDone
            If Application.CalculationState = xlPending Then Application.Calculate
            Application.Wait (Now + TimeValue("00:00:02"))
Loop

以及该逻辑的其他变体，但问题依旧。

完整宏代码 #

Sub Pull_Portfolio_Collateral()
Dim i As Integer
Dim portfolio_rows As Integer

Application.ScreenUpdating = False
portfolio_rows = GetSizePortfolio() + 1

Dim template As Worksheet
Dim portfolio As Worksheet
Dim full_coll_list As Worksheet
Dim individual_list As Worksheet
Dim row_cnt_tmp As Integer

Set portfolio = ActiveWorkbook.Sheets("Portfolio")
Set template = ActiveWorkbook.Sheets("Security - Deal Collateral")
Set full_coll_list = ActiveWorkbook.Sheets("Full Coll List")

For i = 2 To portfolio_rows
     'Set Template sheet
     template.Copy After:=Worksheets(Sheets.Count)
     If portfolio.Range("B" & i).Value <> "" Then
        'Rename Newly created sheet and set the CLO security name
        On Error Resume Next
        ActiveSheet.Name = Left(portfolio.Range("B" & i).Value, 12) & " - Coll"
        Set individual_list = ActiveWorkbook.Sheets(ActiveSheet.Name)
        individual_list.Range("E3").Value = portfolio.Range("B" & i).Value
        'Wait for Application to Calculate before pasting
        Application.Calculate
        Do While Not Application.CalculationState = xlDone
            DoEvents
        Loop
        'Identify the Last Row and copy it to clipboard, then paste in full collateral sheet
        row_cnt_tmp = individual_list.Range("O2").Value
        row_cnt_tmp = row_cnt_tmp + 7
        If i = 2 Then
            full_coll_list.Range("B2:V100000").ClearContents
            individual_list.Range("D8:X" & row_cnt_tmp).Copy
            full_coll_list.Range("B2").PasteSpecial xlPasteValues
        Else
            individual_list.Range("D8:X" & row_cnt_tmp).Copy
            full_coll_list.Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
        End If
        
        
     End If
     

     template.Activate
Next i

individual_list.Range("D8:X" & row_cnt_tmp).Copy
full_coll_list.Range("B2:V").PasteSpecial xlPasteFormats
MsgBox "End Pull Collateral"
End Sub

GetSizePortfolio()函数代码 #

Function GetSizePortfolio() As Integer
Dim rng As Range, n#, b#

Set rng = ActiveWorkbook.Sheets("Portfolio").Range("B2:B1000")
On Error Resume Next
b = WorksheetFunction.CountBlank(rng)
n = rng.Cells.Count - b
On Error GoTo 0

MsgBox "The number of non-blank cells in column " & col & " is " & n
GetSizePortfolio = n


End Function

1. 优化强制计算逻辑 #

当前的等待逻辑可能没覆盖异步计算的所有场景，替换为更严谨的版本：

' 切换为手动计算，避免自动计算干扰
Application.Calculation = xlCalculationManual
' 仅计算当前需要的临时工作表，减少冗余计算
individual_list.Calculate
' 等待全局计算完全完成
Do While Application.CalculationState <> xlDone
    DoEvents ' 释放CPU资源，让Excel计算线程完成任务
Loop
' 按需恢复自动计算
Application.Calculation = xlCalculationAutomatic

关键改进：

• 手动计算模式避免Excel在等待时触发不必要的自动计算，减少干扰
• 直接计算目标工作表，比全局计算更精准高效
• DoEvents让VBA暂时让出资源，比固定等待2秒更灵活，能适配不同计算量的场景

2. 替换剪贴板复制粘贴为直接值传递 #

剪贴板操作易受外部干扰，且依赖计算完成的时机，直接赋值更可靠：

' 替换原来的Copy/PasteSpecial代码块
Dim sourceRng As Range, destRng As Range
Set sourceRng = individual_list.Range("D8:X" & row_cnt_tmp)

If i = 2 Then
    full_coll_list.Range("B2:V100000").ClearContents
    Set destRng = full_coll_list.Range("B2").Resize(sourceRng.Rows.Count, sourceRng.Columns.Count)
Else
    Set destRng = full_coll_list.Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(sourceRng.Rows.Count, sourceRng.Columns.Count)
End If
' 直接赋值，跳过剪贴板
destRng.Value = sourceRng.Value

3. 内存问题排查与优化 #

如果上述方法无效，可能和内存占用有关：

• 清理临时工作表：每次循环复制的新工作表会占用内存，若不需要保留，在循环内添加删除逻辑：

  ' 在If块的末尾添加
  ' individual_list.Delete
  

• 避免Active对象操作：减少ActiveSheet/Activate的使用，直接通过对象引用操作，降低Excel上下文切换开销：

  ' 替换template.Copy后的ActiveSheet操作
  Dim newSheet As Worksheet
  Set newSheet = template.Copy(After:=Worksheets(Sheets.Count))
  On Error Resume Next
  newSheet.Name = Left(portfolio.Range("B" & i).Value, 12) & " - Coll"
  On Error GoTo 0
  Set individual_list = newSheet
  

• 检查易失性公式：模板工作表中的数组公式、外部链接或NOW()/OFFSET()等易失性函数会增加计算负载，可能导致计算延迟，尽量替换为非易失性逻辑。

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