检查选区内公式是不是一样的

liaoliangbang

有时候在接手别人的EXCEL模版时，面对密密麻麻的公式，是不是有点头大，从哪里看起即使切换R1C1模式，也会瞅得眼花，Office内置的公式审核中，没有相关相邻单元格区域公式比对的功能，这里用宏做了个公式检查小助手。
代码如下：
Sub 检查公式是否相同()
Dim myArr
Dim tiped As Boolean
Application.StatusBar = ""
'On Error Resume Next
Call ChangeIntoR1C1mode
xx = Selection.Rows.Count
yy = Selection.Columns.Count
ReDim myArr(1 To xx, 1 To yy)
myJ = True
tiped = False
mJ = True

For Each ce In Selection
   If ce.HasFormula = False Then mJ = False: MsgBox "选择的区域中【cells(" & ce.Row & "," & ce.Column & ")没有公式！检查将退出！": Application.StatusBar = "选择的区域中【cells(" & ce.Row & "," & ce.Column & ")没有公式！检查将退出！": Exit Sub
Next ce


For i = 1 To xx
    For j = 1 To yy

         myFormulaStr = Selection(i, j).FormulaR1C1  'R1C1样式的公式内的文本
         If Selection(i, j).HasArray Then myFormulaStr = "{" & myFormulaStr & "}"   '如果是数组公式，则添加"{"  "}"
         myArr(i, j) = myFormulaStr
         myStr0 = myArr(1, 1)
         myStr1 = myArr(i, j)
        If myStr0 <> myStr1 Then myJ = False
    Next j
Next i

If xx > 1 And yy > 1 Then

   If myArr(1, 1) <> myArr(1, 2) And myArr(1, 1) <> myArr(2, 1) Then
       myTip = MsgBox("行列中x轴和y轴方向公式都不一样！", vbExclamation, "警告！"): Application.StatusBar = "行列中x轴和y轴方向公式都不一样！": tiped = True
   ElseIf tiped = False And myArr(1, 1) <> myArr(1, yy) And myArr(1, 1) <> myArr(xx, 1) Then
       myTip = MsgBox("行列中x轴和y轴方向公式都不一样！", vbExclamation, "警告！"): Application.StatusBar = "行列中x轴和y轴方向公式都不一样！": tiped = True

   ElseIf tiped = False And myArr(1, 1) <> myArr(1, 2) Then myTip = MsgBox("同一行中x轴方向公式不一样！", vbExclamation, "警告！"): Application.StatusBar = "同一行中x轴方向公式不一样！": tiped = True
   ElseIf tiped = False And myArr(1, 1) <> myArr(2, 1) Then myTip = MsgBox("同一列中y轴方向公式不一样！", vbExclamation, "警告！"): Application.StatusBar = "同一列中y轴方向公式不一样！": tiped = True
   ElseIf tiped = False And myArr(1, 1) <> myArr(1, yy) Then myTip = MsgBox("同一行中x轴方向公式不一样！", vbExclamation, "警告！"): Application.StatusBar = "同一行中x轴方向公式不一样！": tiped = True
   ElseIf tiped = False And myArr(1, 1) <> myArr(xx, 1) Then myTip = MsgBox("同一列中y轴方向公式不一样！", vbExclamation, "警告！"): Application.StatusBar = "同一列中y轴方向公式不一样！": tiped = True
   Else
   End If
Else

    If yy > 1 Then
          If tiped = False And myArr(1, 1) <> myArr(1, 2) Then
             myTip = MsgBox("同一行中x轴方向公式不一样！", vbExclamation, "警告！"): Application.StatusBar = "同一行中x轴方向公式不一样！": tiped = True
          ElseIf tiped = False And myArr(1, 1) <> myArr(1, yy) Then
             myTip = MsgBox("同一行中x轴方向公式不一样！", vbExclamation, "警告！"): Application.StatusBar = "同一行中x轴方向公式不一样！": tiped = True
          Else
          End If
    End If

     If xx > 1 Then
         If tiped = False And myArr(1, 1) <> myArr(2, 1) Then
             myTip = MsgBox("同一列中y轴方向公式不一样！", vbExclamation, "警告！"): Application.StatusBar = "同一列中y轴方向公式不一样！": tiped = True
         ElseIf tiped = False And myArr(1, 1) <> myArr(xx, 1) Then
             myTip = MsgBox("同一列中y轴方向公式不一样！", vbExclamation, "警告！"): Application.StatusBar = "同一列中y轴方向公式不一样！": tiped = True
         Else
         End If
     End If
End If
If myJ = True Then
  MsgBox "选区公式一致！": Application.StatusBar = "选区公式一致！": tiped = True
Else
     If tiped = False Then myTip = MsgBox("选区公式不一致！请按行及按列检查！", vbExclamation, "警告！"): Application.StatusBar = "选区公式不一致！请按行及按列检查！"
End If
Call ChangeIntoA1mode
End Sub

Sub ChangeIntoR1C1mode()
Application.ReferenceStyle = xlR1C1 'xlR1C1

End Sub


Sub ChangeIntoA1mode()
Application.ReferenceStyle = xlA1

End Sub

使用方法：
把上面的代码复制到模块中就可以使用了。
选中要比对的单元格区域（注意是相邻区域，不支持非相邻区域，要达到非相邻区域的功能自己去修改代码哦），运行宏“检查公式是否相同”