An automated 'Copy down' for the formulas in the top row of a range

Here's a common case: you have a regular data import into a sheet, and the columns to the right of the 'landing pad' contain formulae performing calculations on that data.

However, this calculation only needs to be performed once, it's the same for every row, and you don't want it dragging down the performance of the whole workbook when you recalculate it for unrelated data updates...

...So you take the formulae in the first row, copy them down, calculate the lot, and replace all those copied-down formulae with the results as static values.

Not included here: the number of rows varies, so you need to vary the depth of the adjacent calculation range.

Attribute VB_Name = "basCopyCalc"
Option Explicit

' Nigel Heffernan Jan 2009 
' Proof-of-concept for an enhanced 'CopyDown' macro




Public Sub CopyCalc(TargetRange As Excel.Range, _ 
                    Optional NoRecopy As Boolean = False, _ 
                    Optional SkipHeader As Boolean = False, _ 
                    Optional SuppressErrors As Boolean = False)

' Copy the formulae in the first row into all rows of the range
' Calculate the entire range
' Overwrite all formulae in the range (except for the first row) with the calculated values

'    NoRecopy:       The overwrite with static values is skipped if the optional NoRecopy parameter is set TRUE
'    SkipHeader:     Common 'use-case' of a range being a table with a header row, and the first row of formulae being row 2
'    SuppressErrors: You are strongly advised to set this TRUE whenever VBA user-defined functions are present in the formulae

' Note that noncontiguous ranges will be processed one area at a time, with each subrange copying down its own first row

If SuppressErrors Then
    On Error GoTo ErrSub
Else
    On Error Resume Next
End If

Dim lngXLCalculation As Excel.XlCalculation
Dim boolScreenUpdate As Boolean
Dim boolEnableEvents As Boolean

Dim rng As Excel.Range
Dim lngRow As Long

If TargetRange Is Nothing Then
    Exit Sub
End If

If SkipHeader = True Then
    lngRow = 2
Else
    lngRow = 1
End If

boolScreenUpdate = Application.ScreenUpdating
boolEnableEvents = Application.EnableEvents

If Application.Calculation <> xlCalculationManual Then
    Application.Calculation = xlCalculationManual
End If

If Application.EnableEvents = True Then
    Application.EnableEvents = False
End If




For Each rng In TargetRange.Areas

    With rng
    
        If .Rows.Count > 1024 Then
            If Application.ScreenUpdating = True Then
                Application.ScreenUpdating = False
            End If
        End If
        
        If .Rows.Count > lngRow Then
        
            ' Copy down formulae
            .Formula = .Rows(lngRow).Formula
            
            .Calculate
            
            ' Overwrite with static values
            If Not NoRecopy Then
                .Worksheet.Range(.Cells(lngRow + 1, 1), .Cells(.Rows.Count, .Columns.Count)).Value2 = .Worksheet.Range(.Cells(lngRow + 1, 1), .Cells(.Rows.Count, .Columns.Count)).Value2
            End If

        End If
        
    End With
    
Next rng

ExitSub:

   
    On Error Resume Next    ' this code must run, no matter what happens
    
    ' Restore prior application settings
    If Application.ScreenUpdating <> boolScreenUpdate Then
        boolScreenUpdate = Application.ScreenUpdating
    End If
    If Application.EnableEvents <> boolEnableEvents Then
        Application.EnableEvents = boolEnableEvents
    End If
    
    Exit Sub
    
ErrSub:

    Dim strMsg As String
    
     strMsg = ""
     strMsg = strMsg & "The CopyCalc operation on range '" & rng.Worksheet.Name & "'!" & rng.Address & " failed: "
     strMsg = strMsg & vbCrLf & vbCrLf
     strMsg = strMsg & "Excel error " & Err.Number & ": " & Error.Description
     strMsg = strMsg & vbCrLf & vbCrLf
     strMsg = strMsg & "There may be an error in the formulas you are attempting to copy. Try a manual copy and see if you can fix the formulas. If this is a system problem, or a macro error, contact support."

    If Err.HelpContext <> 0 Then
        MsgBox strMsg, vbCritical + vbMsgBoxHelpButton, ThisWorkbook.Name & "CopyCalc Error:", Err.HelpFile, Err.HelpContext
    Else
        MsgBox strMsg, vbCritical, ThisWorkbook.Name & "CopyCalc Error:"
    
    End If
    Resume ExitSub
    
Exit Sub
    ' DEBUGGING ONLY: you can only reach this statement by a manual 'Set Next Statement'
    ' use it to identify the bad line if you've placed a breakpoint in the error-handler
    Resume
    
End Sub