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

## No comments:

## Post a Comment