Sub ConvertCellFormulaToUseOffWorksheetNames()

[orangepips]

Wanted to share this with the community after struggling through it.
Basically you select one or more cells and run this Macro, which loops
through each cell in the selection and that cell's offsheet
predecessors. Then if a cell's predecessor has name, it changes the
cell's formula to use that name.

CODE:

Option Explicit
Sub ConvertCellFormulaToUseOffWorksheetNames()

Dim rngCell As Range
Dim ORIGIN As String

Dim LINK_NUMBER As Integer

Dim strOrgnWkbkNme As String
Dim strOrgnShNme As String

Dim strPrecWkbkNme As String
Dim strPrecShNme As String
Dim strPrecNme As String
Dim strPrecColLtr As String
Dim strPrecRowNum As String
Dim strOldPrecFmlaPfx As String
Dim strNewPrecFmlaPfx As String

Dim strRelColRelRow As String
Dim strAbsColRelRow As String
Dim strRelColAbsRow As String
Dim strAbsColAbsRow As String

Dim strNewFormula As String

Application.ScreenUpdating = False

strOrgnWkbkNme = ActiveWorkbook.Name
strOrgnShNme = ActiveWorkbook.ActiveSheet.Name

For Each rngCell In Selection
'On Error GoTo NO_PRECEDENTS 'error handler

Workbooks(strOrgnWkbkNme).Activate
ActiveWorkbook.Sheets(strOrgnShNme).Select
rngCell.Select

rngCell.ShowPrecedents
LINK_NUMBER = 1
ORIGIN = rngCell.Address
strNewFormula = rngCell.Formula

On Error GoTo NO_MORE_PRECEDENTS 'exits loop on no more links

Do
Debug.Print LINK_NUMBER & " : " & rngCell.Formula
ActiveCell.NavigateArrow TowardPRECEDENT:=True,
ArrowNumber:=1, _
LinkNumber:=LINK_NUMBER

If ActiveCell.Address = ORIGIN And
ActiveWorkbook.ActiveSheet.Name = strOrgnShNme Then
Debug.Print "Exit Do"
Exit Do
End If

strPrecWkbkNme = ActiveWorkbook.Name
strPrecShNme = ActiveCell.Parent.Name
If strPrecWkbkNme = strOrgnWkbkNme Then
'Internal Workbook Reference
strOldPrecFmlaPfx = "'" & strPrecShNme & "'!"
strNewPrecFmlaPfx = ""
Else
'External Workbook Reference
strOldPrecFmlaPfx = "'[" & strPrecWkbkNme & "]" &
strPrecShNme & "'!"
strNewPrecFmlaPfx = strPrecWkbkNme & "!"
End If

strPrecNme = GetCellName(ActiveCell)
strPrecColLtr = ColumnLetter(ActiveCell)
strPrecRowNum = ActiveCell.Row

'Debug.Print "Precedent Cell: " & strOldPrecFmlaPfx &
strPrecColLtr & strPrecRowNum

Debug.Print "strPrecNme: " & strPrecNme

'Debug.Print "strPrecColLtr & strPrecRowNum: " &
strPrecColLtr & " " & strPrecRowNum

If strPrecWkbkNme <> strOrgnWkbkNme Then
'Debug.Print "Workbook: " & strOrgnWkbkNme
Workbooks(strOrgnWkbkNme).Activate
'Debug.Print "Worksheet: " & strOrgnShNme
ActiveWorkbook.Sheets(strOrgnShNme).Select
'Debug.Print "Cell"
rngCell.Select
End If

' Update the new formula for the current precedent
If strPrecNme <> "" Then

strRelColRelRow = strOldPrecFmlaPfx & "$" &
strPrecColLtr & "$" & strPrecRowNum
strAbsColRelRow = strOldPrecFmlaPfx & strPrecColLtr &
"$" & strPrecRowNum
strRelColAbsRow = strOldPrecFmlaPfx & "$" &
strPrecColLtr & strPrecRowNum
strAbsColAbsRow = strOldPrecFmlaPfx & strPrecColLtr &
strPrecRowNum

If strNewFormula Like "*" & _
Replace(Replace(strRelColRelRow, "]", "[]]"), "[",
"[[]", 1, 1) & "*" Then
strNewFormula = Replace(strNewFormula, _
strRelColRelRow, _
strNewPrecFmlaPfx & strPrecNme)
End If

If strNewFormula Like "*" & _
Replace(Replace(strAbsColRelRow, "]", "[]]"), "[",
"[[]", 1, 1) & "*" Then
strNewFormula = Replace(strNewFormula, _
strAbsColRelRow, _
strNewPrecFmlaPfx & strPrecNme)
End If

If strNewFormula Like "*" & _
Replace(Replace(strRelColAbsRow, "]", "[]]"), "[",
"[[]", 1, 1) & "*" Then
strNewFormula = Replace(strNewFormula, _
strRelColAbsRow, _
strNewPrecFmlaPfx & strPrecNme)
End If

If strNewFormula Like "*" & _
Replace(Replace(strAbsColAbsRow, "]", "[]]"), "[",
"[[]", 1, 1) & "*" Then
strNewFormula = Replace(strNewFormula, _
strAbsColAbsRow, _
strNewPrecFmlaPfx & strPrecNme)
End If


End If

LINK_NUMBER = LINK_NUMBER + 1

If strPrecWkbkNme = strOrgnWkbkNme Then
'Debug.Print "Workbook: " & strOrgnWkbkNme
Workbooks(strOrgnWkbkNme).Activate
'Debug.Print "Worksheet: " & strOrgnShNme
ActiveWorkbook.Sheets(strOrgnShNme).Select
'Debug.Print "Cell"
rngCell.Select
End If

Loop

NEXT_CELL:
Debug.Print "Old: " & rngCell.Formula
Debug.Print "New: " & strNewFormula

'ActiveCell.Formula = strNewFormula
ActiveWorkbook.ActiveSheet.ClearArrows

Next rngCell

Application.ScreenUpdating = True

Exit Sub

NO_MORE_PRECEDENTS:
'Debug.Print Err.Description
Debug.Print "No More Precedents"
Err.Clear
Resume Next

End Sub


Function GetCellName(oCell As Range) As String

Dim oName As Name
Dim rgName As Range
Dim rgIntersect As Range

'Debug.Print "Function GetCellName: " & oCell.Address

GetCellName = ""

For Each oName In oCell.Parent.Parent.Names
On Error Resume Next
'Debug.Print "Evaluating Name: " & oName.Name & oName.RefersTo
Set rgName = Nothing
Set rgName = oName.RefersToRange
If Not rgName Is Nothing Then
If rgName.Parent Is oCell.Parent Then
Set rgIntersect = Intersect(oCell, rgName)

If Not rgIntersect Is Nothing And rgName.Cells.Count =
1 Then
GetCellName = oName.Name
Exit Function
End If
End If
End If
Next oName
End Function

Function ColumnLetter(rngCell As Range) As String
ColumnLetter = Replace(rngCell.Address(0, 0), rngCell.Row, "")
End Function

 

[Mark]

I don't mean to rain on your parade, but I believe that
Insert...Name...Apply already does that.

 

[orangepips]

"Insert > Name > Apply" only works for same worksheet predessors.

This macro works for predecessors from other sheets/external workbooks.