Friday, February 24, 2012

Convert all formulas to absolute/relative:

Sub MakeAbsoluteOrRelative()
   


    Dim RdoRange As Range, rCell As Range

    Dim i As Integer

    Dim Reply As String

    

     'Ask whether Relative or Absolute

    Reply = InputBox("Change formulas to?" & Chr(13) & Chr(13) _

    & "Relative row/Absolute column = 1" & Chr(13) _

    & "Absolute row/Relative column = 2" & Chr(13) _

    & "Absolute all = 3" & Chr(13) _

    & "Relative all = 4", "OzGrid Business Applications")

    

     'They cancelled

    If Reply = "" Then Exit Sub

    

    On Error Resume Next

     'Set Range variable to formula cells only

    Set RdoRange = Selection.SpecialCells(Type:=xlFormulas)

    

     'determine the change type

    Select Case Reply

    Case 1 'Relative row/Absolute column

        

        For Each rCell In RdoRange

            If rCell.HasArray Then

                If Len(rCell.FormulaArray) < 255 Then

                    rCell.FormulaArray = _

                    Application.ConvertFormula _

                    (Formula:=rCell.FormulaArray, _

                    FromReferenceStyle:=xlA1, _

                    ToReferenceStyle:=xlA1, ToAbsolute:=xlRelRowAbsColumn)

                End If

            Else

                If Len(rCell.Formula) < 255 Then

                    rCell.Formula = _

                    Application.ConvertFormula _

                    (Formula:=rCell.Formula, _

                    FromReferenceStyle:=xlA1, _

                    ToReferenceStyle:=xlA1, ToAbsolute:=xlRelRowAbsColumn)

                End If

            End If

        Next rCell

        

    Case 2 'Absolute row/Relative column

        For Each rCell In RdoRange

            If rCell.HasArray Then

                If Len(rCell.FormulaArray) < 255 Then

                    rCell.FormulaArray = _

                    Application.ConvertFormula _

                    (Formula:=rCell.FormulaArray, _

                    FromReferenceStyle:=xlA1, _

                    ToReferenceStyle:=xlA1, ToAbsolute:=xlAbsRowRelColumn)

                End If

            Else

                If Len(rCell.Formula) < 255 Then

                    rCell.Formula = _

                    Application.ConvertFormula _

                    (Formula:=rCell.Formula, _

                    FromReferenceStyle:=xlA1, _

                    ToReferenceStyle:=xlA1, ToAbsolute:=xlAbsRowRelColumn)

                End If

            End If

        Next rCell

        

    Case 3 'Absolute all

        For Each rCell In RdoRange

            If rCell.HasArray Then

                If Len(rCell.FormulaArray) < 255 Then

                    rCell.FormulaArray = _

                    Application.ConvertFormula _

                    (Formula:=rCell.FormulaArray, _

                    FromReferenceStyle:=xlA1, _

                    ToReferenceStyle:=xlA1, ToAbsolute:=xlAbsolute)

                End If

            Else

                If Len(rCell.Formula) < 255 Then

                    rCell.Formula = _

                    Application.ConvertFormula _

                    (Formula:=rCell.Formula, _

                    FromReferenceStyle:=xlA1, _

                    ToReferenceStyle:=xlA1, ToAbsolute:=xlAbsolute)

                End If

            End If

        Next rCell

        

    Case 4 'Relative all

        For Each rCell In RdoRange

            If rCell.HasArray Then

                If Len(rCell.FormulaArray) < 255 Then

                    rCell.FormulaArray = _

                    Application.ConvertFormula _

                    (Formula:=rCell.FormulaArray, _

                    FromReferenceStyle:=xlA1, _

                    ToReferenceStyle:=xlA1, ToAbsolute:=xlRelative)

                End If

            Else

                If Len(rCell.Formula) < 255 Then

                    rCell.Formula = _

                    Application.ConvertFormula _

                    (Formula:=rCell.Formula, _

                    FromReferenceStyle:=xlA1, _

                    ToReferenceStyle:=xlA1, ToAbsolute:=xlRelative)

                End If

            End If

        Next rCell

        

    Case Else 'Typo

        MsgBox "Change type not recognised!", vbCritical, _

        "OzGrid Business Applications"

    End Select

    

     'Clear memory

    Set RdoRange = Nothing

End Sub

No comments:

Post a Comment