Excel VBA宏复制功能异常行为排查与解决方案咨询

编辑补充：触发问题的条件似乎是当LastRowNo等于常量StartRowNo（值为3）时，宏会将单元格复制到自身。我在复制函数前添加了If LastRowNo = StartRowNo Then Exit Sub语句，问题暂时解决，但这只是临时 workaround，因为理论上单元格复制到自身不应引发问题，特此保留问题以寻求根源解析。

我编写的VBA宏最初运行正常，但偶尔会出现异常：将单元格A3的内容复制到整个工作表的第1至25列，范围直至LastRowNo变量获取的最后一行。

引发问题的代码行如下：

.Range(StartRow).Copy _
    Destination:=.Range(StartRow & ":A" & LastRowNo).SpecialCells(xlCellTypeBlanks)

若注释该行代码，下方的复选框复制代码会出现同样的异常，将复选框复制至相同范围：

For ColumnNo = 16 To 25
      Escopo.Cells(StartRowNo, ColumnNo).Copy _
         Destination:=.Range(Escopo.Cells(StartRowNo, ColumnNo), Escopo.Cells(LastRowNo, ColumnNo)).SpecialCells(xlCellTypeBlanks)
Next

更奇怪的是，假设某次错误发生时LastRowNo的值为20，删除所有数据后将LastRowNo设置为4，宏仍会复制到第20行，只有当LastRowNo设为大于20的值时，范围才会更新。仿佛宏在End Sub后仍留存该值，仅会被更大的值覆盖。

我无法稳定复现该错误，其出现无明显规律。

完整代码 #

FormatWB 主过程 #

Sub FormatWB()
    
    Dim StartRow As String
    Dim LastRowNo As Long
    Dim ColumnNo As Long
    Dim Escopo As Worksheet
    Dim Material As Worksheet
    Dim PrecoMTL As Worksheet
    Dim PrecoRev As Worksheet
    Dim Orcamento As Worksheet
    Const StartRowNo = 3
    
    Set Escopo = ActiveWorkbook.Worksheets("Escopo")
    Set Material = ActiveWorkbook.Worksheets("Material")
    Set PrecoMTL = ActiveWorkbook.Worksheets("Preço Material")
    Set PrecoRev = ActiveWorkbook.Worksheets("Preço Revestimento")
    Set Orcamento = ActiveWorkbook.Worksheets("Orçamento Final")
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
        With Escopo '根据非空单元格数量计算限制范围
            LastRowNo = .Cells(.Rows.Count, "B").End(xlUp).Row '该值会在RemoveSumDuplicates过程中更新
                If LastRowNo < StartRowNo Then Exit Sub
            StartRow = "A" & StartRowNo
                Call RemoveSumDuplicates(StartRowNo, LastRowNo, StartRow)
        End With
        
        With ActiveWorkbook '统一格式化所有工作表，范围到指定最后一列
            FormatSheet Escopo.Range(StartRow & ":Y" & LastRowNo)
            FormatSheet Material.Range(StartRow & ":N" & LastRowNo)
            FormatSheet PrecoMTL.Range(StartRow & ":P" & LastRowNo)
            FormatSheet PrecoRev.Range(StartRow & ":O" & LastRowNo)
            FormatSheet Orcamento.Range(StartRow & ":Q" & LastRowNo)
        End With
        
        With Escopo
            On Error Resume Next
                .Range("A3").Formula = "=IF(ISBLANK(B3),"""",IFERROR(A2+1,1))"
                .Range(StartRow & ":A" & LastRowNo).Font.Bold = True
                .Range("P3:R3").CellControl.SetCheckbox
                .Range("S3").FormulaArray = "=INDEX('Database QPs e IPs'!$H$2:$H$150,MATCH(1,(Escopo!$K3='Database QPs e IPs'!$A$2:$A$150)*(Escopo!$L3='Database QPs e IPs'!$B$2:$B$150),0))"
                .Range("T3").FormulaArray = "=INDEX('Database QPs e IPs'!$G$2:$G$150,MATCH(1,(Escopo!$K3='Database QPs e IPs'!$A$2:$A$150)*(Escopo!$L3='Database QPs e IPs'!$B$2:$B$150),0))"
                .Range("U3").FormulaArray = "=INDEX('Database QPs e IPs'!$I$2:$I$150,MATCH(1,(Escopo!$K3='Database QPs e IPs'!$A$2:$A$150)*(Escopo!$L3='Database QPs e IPs'!$B$2:$B$150),0))"
                .Range("V3").FormulaArray = "=INDEX('Database QPs e IPs'!$N$2:$N$150,MATCH(1,(Escopo!$K3='Database QPs e IPs'!$A$2:$A$150)*(Escopo!$L3='Database QPs e IPs'!$B$2:$B$150),0))"
                .Range("W3").FormulaArray = "=INDEX('Database QPs e IPs'!$K$2:$K$150,MATCH(1,(Escopo!$K3='Database QPs e IPs'!$A$2:$A$150)*(Escopo!$L3='Database QPs e IPs'!$B$2:$B$150),0))"
                .Range("X3").FormulaArray = "=INDEX('Database QPs e IPs'!$J$2:$J$150,MATCH(1,(Escopo!$K3='Database QPs e IPs'!$A$2:$A$150)*(Escopo!$L3='Database QPs e IPs'!$B$2:$B$150),0))"
                .Range("Y3").FormulaArray = "=INDEX('Database QPs e IPs'!$O$2:$O$150,MATCH(1,(Escopo!$K3='Database QPs e IPs'!$A$2:$A$150)*(Escopo!$L3='Database QPs e IPs'!$B$2:$B$150),0))"
                .Range(StartRow).Copy _
                    Destination:=.Range(StartRow & ":A" & LastRowNo).SpecialCells(xlCellTypeBlanks)
                For ColumnNo = 16 To 25
                    Escopo.Cells(StartRowNo, ColumnNo).Copy _
                        Destination:=.Range(Escopo.Cells(StartRowNo, ColumnNo), Escopo.Cells(LastRowNo, ColumnNo)).SpecialCells(xlCellTypeBlanks)
                Next
        End With
        
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

FormatSheet 格式化过程 #

Sub FormatSheet(rng As Range)
    With rng
        .UnMerge
        .Borders.LineStyle = xlContinuous
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .NumberFormat = "General"
        .Font.Bold = False
        .Font.Italic = False
        .Font.Underline = False
        .Font.Name = "Calibri"
        .Font.Size = 11
        .Interior.ColorIndex = 0
        .Font.Color = vbBlack
    End With
End Sub

RemoveSumDuplicates 去重求和过程 #

Sub RemoveSumDuplicates(StartRowNo As Long, LastRowNo As Long, StartRow As String)
    Dim Value As Object
    Dim RowNo As Long
    Dim Label As String

    Set Value = CreateObject("Scripting.Dictionary")

    For RowNo = StartRowNo To LastRowNo
        Label = Cells(RowNo, 2)
        Value(Label) = Cells(RowNo, 7) + Value(Label)
    Next RowNo
    
    Range(StartRow & ":Y" & LastRowNo).RemoveDuplicates Columns:=Array(2, 2)
    LastRowNo = Cells(Rows.Count, "B").End(xlUp).Row

    For RowNo = StartRowNo To LastRowNo
        Label = Cells(RowNo, 2)
            If Not Cells(RowNo, 7) = Value(Label) Then Cells(RowNo, 7) = Value(Label)
    Next RowNo
End Sub

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