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
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