如何让复制MISC格式并添加计算的VBA宏仅单次运行完成？

问题根源 #

你的宏需要运行两次才生效，核心问题有3个：

1. 变量拼写错误：Contine = True 应为 Continue = True，导致逻辑判断变量初始值异常。
2. 列号计算时机错误：lastCol2 在格式复制前就已计算，此时新列还未添加，第一次运行时计算的是旧列而非新复制的列。
3. 粘贴操作未指定类型：默认的PasteSpecial会粘贴全部内容，而你只需要复制格式，可能引发意外覆盖。

修正后的代码 #

Sub Model2()
    
    Dim ws As Worksheet
    Dim ws2 As Worksheet
    Dim lastCol As Long
    Dim newCalcCol As Long
    Dim Continue As Boolean
    
    Set ws = ThisWorkbook.Worksheets("MODEL 2")
    Set ws2 = ThisWorkbook.Worksheets("MISC")
    
    Continue = True
    ' 获取MODEL 2第29行最后一列右侧的空列（粘贴起始位置）
    lastCol = ws.Cells(29, Columns.Count).End(xlToLeft).Offset(0, 1).Column
    
    Application.ScreenUpdating = False
    
    If ws.Range("C29").Value <> "" Then
        ' 仅粘贴格式，避免粘贴MISC中的无关内容
        ws2.Range("A1:B39").Copy
        ws.Cells(29, lastCol).PasteSpecial xlPasteFormats
        
        ' 复制格式后，确定要添加计算的列（这里假设是粘贴的第二列，需调整可直接改为lastCol）
        newCalcCol = lastCol + 1
        
        ' 在新复制的列中添加计算逻辑
        ws.Cells(29, newCalcCol).Value = ws.Cells(29, 3).Value
        ws.Cells(54, newCalcCol).FormulaR1C1 = "=SUM(R[-22]C:R[-2]C)"
    Else
        MsgBox "请填写所有黄色区域的必填数据后再执行计算。", vbOKOnly
        Continue = False
    End If
    
    Application.CutCopyMode = False ' 清除复制选区的虚线框
    Application.ScreenUpdating = True

End Sub

关键修改说明 #

• 修复Continue变量的拼写错误，确保逻辑判断正常执行。
• 将计算列的确定移到格式复制之后，直接基于粘贴起始列推导新列位置，保证每次操作都针对刚添加的新列。
• 使用PasteSpecial xlPasteFormats仅粘贴格式，完全匹配你"MISC仅包含格式"的需求，避免意外覆盖现有数据。
• 添加Application.CutCopyMode = False清除复制状态，优化操作体验。

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