VBA实用小程序：核查并标记公式是否被正确复制

下面的代码将复制活动工作表，然后标记公式，使用阴影显示已复制哪些以及从何处复制。它从左到右、从上到下进行核查。

• 纯色 = 此单元格尚未从左侧或上方复制，即它是新的
• 水平剖面线 = 此单元格已从左侧复制
• 垂直剖面线 = 此单元格已从上方复制
• 交叉影线 = 此单元格已从左侧+上方复制

这个想法的目的是为了更容易检查复杂的工作表，因为你只需要检查纯色单元格，然后确认它们已被正确复制。如果表中间有一个公式损坏的单元格，它将是一个非常明显的纯色。

显然，代码复制了工作表，然后逐个查看每一单元格，首先从左侧复制公式，然后从上方复制，看看它是否给出相同的结果。这有点慢，但它是检查公式是否被完全复制的唯一可靠方法。

下面给出了一个示例，在表格中间包含一个具有不同公式的“特殊”单元格。

完整的代码如下：

Sub MarkFormulae()

Dim V As Variant

Dim rng As Range

Dim S As Worksheet

Dim i As Long

Dim j As Long

Dim r As Long

Dim C As Long

Dim ii As Long

Dim jj As Long

Dim n As Long

Dim skip As Boolean

Dim vbLeft As Long

Dim vbAbove As Long

vbLeft = 1

vbAbove = 2

Dim colorLeft As Long

Dim colorAbove As Long

Dim colorBoth As Long

Dim colorNone As Long

colorLeft =16773571

colorAbove= 10092543

colorBoth =6750054

colorNone =9486586

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

Application.EnableEvents = False

ActiveSheet.Copy

Set S =ActiveSheet

S.Cells.UnMerge

Cells.Interior.Color = xlNone

V =Range(Cells(1, 1), S.Cells.SpecialCells(xlCellTypeLastCell).Offset(1,1)).Formula

r =UBound(V, 1)

C =UBound(V, 2)

ReDim A(r,C) As Long

For i = 1 To r - 1

Application.StatusBar = "Processing " & S.Name &": row " & i & " of " & r

For j = 1 To C - 1

If Left$(V(i, j), 1) = "=" Then

Cells(i, j).Copy

Cells(i, j + 1).PasteSpecial Paste:=xlPasteFormulas

If Cells(i, j + 1).Formula = V(i, j + 1) Then

A(i, j + 1) = A(i, j + 1) Or vbLeft

End If

Cells(i, j + 1).Formula = V(i, j + 1)

Cells(i, j).Copy

On Error Resume Next

Cells(i + 1, j).PasteSpecial Paste:=xlPasteFormulas

skip= (Err.Number <> 0)

On Error GoTo 0

If skip = False Then

If Cells(i + 1, j).Formula = V(i + 1, j) Then

A(i + 1, j) = A(i + 1, j) Or vbAbove

End If

Cells(i + 1, j).Formula = V(i + 1, j)

Select Case A(i, j)

Case vbLeft

Cells(i, j).Interior.Pattern = xlLightHorizontal

Cells(i, j).Interior.PatternColor = 6737151

Case vbAbove

Cells(i, j).Interior.Pattern = xlLightVertical

Cells(i, j).Interior.PatternColor = 6737151

Case vbLeft + vbAbove

Cells(i, j).Interior.Pattern = xlGrid

Cells(i, j).Interior.PatternColor = 6737151

Case Else

Cells(i, j).Interior.Color = colorNone

End Select

End If

End If

Next j

DoEvents

Next i

Application.CutCopyMode = False

Cells(1,1).Select

Application.Calculation = xlCalculationAutomatic

Application.EnableEvents = True

Application.StatusBar = False

End Sub

注：本程序整理自www.mrexcel.com，供学习参考。