VBA Code


Sub Extract_Formulas()
' Written by Barrie Davidson
Dim formula1, formula2, formula3
Dim position1, position2, position3 As Integer

On Error Resume Next
For Each cell In Selection
    position1 = InStr(cell.Formula, "+")
    position2 = InStr(position1 + 1, cell.Formula, "+")
    position3 = InStr(position2 + 1, cell.Formula, "+")
    formula1 = Mid(cell.Formula, 1, position1 - 1)
    If position1 = 0 Then
        formula1 = cell.Formula
        formula2 = 0
        formula3 = 0
    Else
        If position2 = 0 Then
            formula2 = "=" & Mid(cell.Formula, position1 + 1, _
                Len(cell.Formula) - position2 - position1)
            formula3 = 0
            Else
            formula2 = "=" & Mid(cell.Formula, position1 + 1, _
                position2 - position1 - 1)
            formula3 = "=" & Mid(cell.Formula, position2 + 1, _
                Len(cell.Formula) - position3 - position2)
        End If
    End If
    cell.Offset(0, 1).Formula = formula1
    cell.Offset(0, 2).Formula = formula2
    cell.Offset(0, 3).Formula = formula3
Next cell

End Sub