VB and VBA Users Source Code: Extracting the formulas from an Excel Range
[
Home
|
Contents
|
Search
|
Reply
| Previous | Next ]
VB/VBA Source Code
Extracting the formulas from an Excel Range
By:
Andrew Baker
Email (spam proof):
Email the originator of this post
Date:
Tuesday, November 20, 2001
Hits:
1280
Category:
Unspecified
Article:
The following code extracts and pastes the equation/formulas from an Excel range into another Excel range as text. 'Purpose : Extracts the formulas from a range 'Inputs : rngSource The range to extract the formulas from. 'Outputs : Returns a one based 2d variant string array of formulas, or empty if fails 'Author : Andrew Baker 'Date : 31/12/2000 13:51 'Notes : 'Revisions : Function FormulasExtract(rngSource As Excel.Range) As Variant Dim lThisRow As Long, lThisCol As Long, avFormulas As Variant On Error Goto ErrFailed 'Extract the formulas avFormulas = rngSource.SpecialCells(xlFormulas).Formula 'Convert the formulas to text For lThisRow = 1 To UBound(avFormulas, 2) For lThisCol = 1 To UBound(avFormulas) avFormulas(lThisCol, lThisRow) = "'" & avFormulas(lThisCol, lThisRow) Next Next FormulasExtract = avFormulas Exit Function ErrFailed: Debug.Print Err.Description Debug.Assert False FormulasExtract = Empty Exit Function Resume End Function 'Purpose : Write a 2d array to a range on an Excel sheet. 'Inputs : rngOutput The top left cell in the range to write the array to e.g. Range("A1") ' avValues An array of the values to write to the above range. ' [bTranspose] If true will transpose the result i.e. columns and rows will swap positions. ' [bStoreDatesAsLong] If True will convert an dates in the array to longs. This ' prevents date conversion problems when reading the information ' back from the range. 'Outputs : Returns the error number if an error occurs 'Author : Andrew Baker 'Date : 31/12/2000 13:51 'Notes : 'Revisions : Function ArrayToRange(rngOutput As Excel.Range, avValues As Variant, Optional bTranspose As Boolean = False, Optional bStoreDatesAsLong As Boolean = False) As Long Dim lThisRow As Long, lThisCol As Long Dim lLastRow As Long, lLastCol As Long Dim lNumRows As Long, lNumCols As Long Dim lFirstRow As Long, lFirstCol As Long On Error GoTo ErrFailed If IsArray(avValues) Then lFirstRow = LBound(avValues) lLastRow = UBound(avValues) lFirstCol = LBound(avValues, 2) lLastCol = UBound(avValues, 2) lNumRows = lLastRow - lFirstRow + 1 lNumCols = lLastCol - lFirstCol + 1 If bStoreDatesAsLong Then 'Convert dates to longs For lThisRow = lFirstRow To lLastRow For lThisCol = lFirstCol To lLastCol If IsDate(avValues(lThisRow, lThisCol)) Then avValues(lThisRow, lThisCol) = CLng(CDate(avValues(lThisRow, lThisCol))) End If Next Next End If If bTranspose Then 'Write array values to range transposing values With rngOutput .Parent.Range(.Cells(1), .Cells(lNumCols, lNumRows)).Value = Application.WorksheetFunction.Transpose(avValues) End With Else 'Write array values to range With rngOutput .Parent.Range(.Cells(1), .Cells(lNumRows, lNumCols)).Value = avValues End With End If End If Exit Function ErrFailed: 'Return and clear error ArrayToRange = Err.Number On Error GoTo 0 End Function 'Demonstrates how to extract the formulas from a range Sub Test() Dim avFormulas As Variant, lThisRow As Long, lThisCol As Long 'Place some simple formulas in a range For lThisRow = 1 To 3 For lThisCol = 1 To 3 Range("a1").Cells(lThisRow, lThisCol).Formula = "=" & lThisRow & "+" & lThisCol Next Next 'Extract the formulas as text avFormulas = FormulasExtract(Range("A1:C3")) 'Write the formulas to a range ArrayToRange Range("d1"), avFormulas End Sub
Terms and Conditions
Support this site
Download a trial version of the Excel Workbook Rebuilder
