• If you would like to post, please check out the MrExcel Message Board FAQ and click here to register.
    If you forgot your password, you can reset your password.
  • Excel articles and downloadable files provided in the articles have not been reviewed by MrExcel Publishing. Please apply the provided methods / codes and open the files at your own risk.
    If you have any questions regarding an article, please use the Article Discussion section.
Dermot

Code for marking formulae as a check they have been copied correctly

This code will make a copy of the active sheet and then mark up the formulae, using shading to show which ones have been copied, and from where. It works from left to right, top to bottom.
Solid colour = this cell has NOT been copied from left or above, ie it is new
Horizontal hatch = this cell has been copied from the left
Vertical hatch = this cell has been copied from above
Cross hatch = this cell has been copied from the left+above

The idea is to make it much easier to check a complex sheet, because you only have to check the solid coloured cells and then confirm they have been copied correctly. If there is a cell with a corrupted formula in the middle of a table, it will be a very obvious solid colour.

For obvious reasons, the code makes a copy of the sheet, and then it literally looks at each cell, copying in the formula first from left, then from above, to see if it gives the same result. This is a bit slow, but it is the only sure way to check that formulae have been copied identically.

An example is given below, including a "rogue" cell in the middle of the table with a different formula.
MarkedFormulae.jpg


VBA Code:
Sub MarkFormulae()
  Dim V As Variant, rng As Range, S As Worksheet
  Dim i As Long, j As Long, r As Long, C As Long, ii As Long, jj As Long, n As Long, skip As Boolean
  Dim vbLeft As Long, vbAbove As Long
  vbLeft = 1: vbAbove = 2
  Dim colorLeft As Long, colorAbove As Long, colorBoth As Long, 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
Excel Version
365, 2019, 2016, 2013, 2011, 2010, 2007
Author
Dermot
Views
47
First release
Last update
Rating
0.00 star(s) 0 ratings

More Excel articles from Dermot

Some videos you may like

This Week's Hot Topics

Top