Sub test_arr_rngPrecedents()
Dim shtOrig As Worksheet, shtDest As Worksheet
Set shtOrig = ActiveSheet
Dim arr As Variant
Dim r As Range, rng As Range, rngP As Range, _
rngJoin As Range, _
rngOrig As Range, rngDest As Range
Set rngOrig = Selection
Set rngDest = Application.InputBox("Choose destination", Type:=8)
Set shtDest = rngDest.Parent
Dim str As String
Dim rw As Long, col As Long, _
i As Long
For rw = 1 To rngOrig.rows.Count
For col = 1 To rngOrig.Columns.Count
Set rng = Worksheets(shtOrig.Name).Range(rngOrig.Cells(rw, col).Address)
arr = arr_rngPrecedents(rng)
str = rng.Formula
For i = LBound(arr, 1) To UBound(arr, 1)
str = Replace(str, arr(i, 2), arr(i, 1) & "!" & arr(i, 2))
Next i
With shtDest
rngDest.offset(rw - 1, col - 1) = str
End With
Next col
Next rw
End Sub
Function arr_rngPrecedents(gnr As Range) As Variant
' ~~ Determine All Precedent Cells – A Nice Example Of Recursion
' https://colinlegg.wordpress.com/2014/01/14/vba-determine-all-precedent-cells-a-nice-example-of-recursion/
Dim dict As scripting.Dictionary
Set dict = GetAllPrecedents(gnr)
Dim arrO As Variant, arrT As Variant
ReDim arrO(0 To dict.Count, _
0 To 2)
Dim i As Long
' Debug.Print "==="
If dict.Count = 0 Then
Debug.Print gnr.Address(external:=True); " has no precedent cells."
Else
For i = LBound(dict.keys) To UBound(dict.keys)
arrT = Replace(dict.keys()(i), "[", vbNullString)
arrT = Split(arrT, "]")
arrO(i, 0) = arrT(0) ' ~~ Workbook
arrT = Split(arrT(1), "!")
arrO(i, 1) = arrT(0) ' ~~ Worksheet
arrO(i, 2) = arrT(1) ' ~~ Range
' Debug.Print "[ Level:"; dict.Items()(i); "]";
' Debug.Print "[ Address: "; dict.keys()(i); " ]"
Next i
End If
' Debug.Print "==="
arr_rngPrecedents = arrO
End Function
Public Function GetAllPrecedents(ByRef rngToCheck As Range) As scripting.Dictionary
'won't navigate through precedents in closed workbooks
'won't navigate through precedents in protected worksheets
'won't identify precedents on hidden sheets
Const lngTOP_LEVEL As Long = 1
Dim dict As scripting.Dictionary
Set dict = New scripting.Dictionary
Dim strKey As String
Application.ScreenUpdating = False
GetPrecedents rngToCheck, dict, lngTOP_LEVEL
Set GetAllPrecedents = dict
Application.ScreenUpdating = True
End Function
Private Sub GetPrecedents(ByRef gnr As Range, _
ByRef tcid As scripting.Dictionary, _
ByVal lngLevel As Long)
Dim rng As Range, rngFormulas As Range
If Not gnr.Worksheet.ProtectContents Then
If gnr.Cells.CountLarge > 1 Then 'Change to .Count in XL 2003 or earlier
On Error Resume Next
Set rngFormulas = gnr.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
Else
If gnr.HasFormula Then Set rngFormulas = gnr
End If
If Not rngFormulas Is Nothing Then
For Each rng In rngFormulas.Cells
GetCellPrecedents rng, tcid, lngLevel
Next rng
rngFormulas.Worksheet.ClearArrows
End If
End If
End Sub
Private Sub GetCellPrecedents(ByRef gnr As Range, _
ByRef tcid As scripting.Dictionary, _
ByVal lngLevel As Long)
Dim rng As Range, rngPrecedent As Range
Dim strPrecedentAddress As String
Dim lngArrow As Long, lngLink As Long
Dim x As Long, y As Long, _
xP As Long, yP As Long
Dim flg As Boolean, blnNewArrow As Boolean
Do
lngArrow = lngArrow + 1
blnNewArrow = True
lngLink = 0
Do
lngLink = lngLink + 1
gnr.ShowPrecedents
On Error Resume Next
Set rngPrecedent = gnr.NavigateArrow(True, lngArrow, lngLink)
If Err.Number <> 0 Then _
Exit Do
On Error GoTo 0
' ~~ Match absolute/relative range format _
[1, 1] = $r$c _
[1, 0] = r$c _
[0, 1] = $rc _
[0, 0] = rc
For Each rng In rngPrecedent
For x = 1 To 0 Step -1 ' ~~ Must go backwards o/w won't capture $r$c
For y = 1 To 0 Step -1
If InStr(gnr.Formula, rng.Address(x, y)) > 0 Then
xP = x: yP = y
flg = True
Exit For
End If
Next y
If flg = True Then _
Exit For
Next x
If flg = True Then _
Exit For
Next rng
flg = False
strPrecedentAddress = rngPrecedent.Address(xP, yP, xlA1, True)
If strPrecedentAddress = gnr.Address(xP, yP, xlA1, True) Then
Exit Do
Else
blnNewArrow = False
If Not tcid.Exists(strPrecedentAddress) Then
tcid.Add strPrecedentAddress, lngLevel
GetPrecedents rngPrecedent, tcid, lngLevel + 1
End If
End If
Loop
If blnNewArrow Then Exit Do
Loop
End Sub
