Option Explicit
Sub AbsoleteNamesWithRelativeRefs()
'We're going to be changing a lot of formulas. Have the sheet delate updating the formulas until after we're done.
Application.Calculation = xlCalculationManual
Dim tempFormula As String
Dim refersTo_replacement As String
Dim i As Integer
Dim xName As Name
Dim rng As Range
Dim sht As Worksheet
For Each sht In ThisWorkbook.Sheets
If This_Sheet_Has_At_Least_One_Formula_In_It(sht.Name) = False Then GoTo Next_Sheet
For Each rng In sht.Cells.SpecialCells(xlCellTypeFormulas)
ReDim arrayOfNamedRangesInCurrentCellFormula(0 To 0) As String
For Each xName In ThisWorkbook.Names
If InStr(rng.Formula, xName.Name) > 0 Then arrayOfNamedRangesInCurrentCellFormula = Append_StringType(arrayOfNamedRangesInCurrentCellFormula, xName.Name)
Next xName
'If the current rng doesn't have any named range cell references (just absolute), skip the remaining steps.
If UBound(arrayOfNamedRangesInCurrentCellFormula) = 0 Then GoTo Next_Range
'Sort the named ranges referenced in this rng by length in ascending order with Quicksort__Of_StringArray_By_Length.
arrayOfNamedRangesInCurrentCellFormula = Quicksort__Of_StringArray_By_Length(arrayOfNamedRangesInCurrentCellFormula, 0, UBound(arrayOfNamedRangesInCurrentCellFormula))
'Call MA(arrayOfNamedRangesInCurrentCellFormula) 'Uncomment to view the output from the Sort for the very first rng. (It will quit execution after that.)
tempFormula = rng.Formula
'We want to substitute larger named range names FIRST, so we DECREMENT (because we SortA previously).
For i = UBound(arrayOfNamedRangesInCurrentCellFormula) To 1 Step -1
refersTo_replacement = Replace(Replace(ThisWorkbook.Names.Item(arrayOfNamedRangesInCurrentCellFormula(i)).RefersTo, "=", ""), "$", "")
tempFormula = Replace_NamedRanges(tempFormula, "[&%^*/+-=>< ,:)( ]" & arrayOfNamedRangesInCurrentCellFormula(i) & "[&%^*/+-=>< ,:)( ]", arrayOfNamedRangesInCurrentCellFormula(i), refersTo_replacement)
Next i
'(Uncomment these to lines to view examples in the immediate (Ctrl+G) window.
'Debug.Print "--------"
'Debug.Print "From range " & rng.Address & " in sheet " & rng.Parent.Name & ","
'Debug.Print tempFormula
'Debug.Print ""
'Debug.Print "Original formula: " & rng.Formula
'Debug.Print ""
rng.Formula = tempFormula '***
Next_Range:
Next rng
Next_Sheet:
Next sht
'Have Excel now calculate the change in all formulas.
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Test__All_Start_Locations_Of_Named_Range()
'A regular expression. What's in between the [] is all characters that we are looking to see is to the left
'and right of our named range's names as we search for them (and replace them) in the following function.
Dim isAnOperatorInExcelFormulas As String
isAnOperatorInExcelFormulas = "[&%^*/+-=>< ,:)( ]"
'We can have a named range named "a".
Dim namedRangesName As String
namedRangesName = "a"
'Let's really test this out by putting "a" at the end of the formula, as well as have "aa" and "concAtenAte" in the formula.
Dim excelFormula As String
excelFormula = "=d*e+a-f+aa*b+CONCATENATE(d,f)+a"
MsgBox Replace_NamedRanges(excelFormula, isAnOperatorInExcelFormulas & namedRangesName & isAnOperatorInExcelFormulas, namedRangesName, "=Sheet1!A1")
End Sub
Function Replace_NamedRanges(strValue As String, strPattern As String, namedRangesName As String, replacement As String)
'https://stackoverflow.com/questions/8301622/excel-vba-regex-match-position
'This assumes that lowercase "|" is NOT in the strValue anywhere. Change to another character if this is not true!
strValue = strValue & "*" 'just in case the last character in the formula is the end of a named range.
Dim location As Integer
With CreateObject("VBScript.RegExp")
.Pattern = strPattern
.IgnoreCase = False
Look_For_More_Occurrences:
If .test(strValue) = True Then
'+ 1 because it's a string with starting index of 1 instead of 0.
'And another + 1 because without it, that's where the operator is, not where the named range's first character starts.
location = .Execute(strValue)(0).firstindex + 1 + 1
strValue = SubString(strValue, 1, location - 1) & "|" & SubString(strValue, location + Len(namedRangesName), Len(strValue))
GoTo Look_For_More_Occurrences
End If
End With
strValue = Replace(strValue, "|", replacement)
Replace_NamedRanges = SubString(strValue, 1, Len(strValue) - 1) 'omit the last character *.
End Function
Function Quicksort__Of_StringArray_By_Length(vArray As Variant, arrLbound As Long, arrUbound As Long)
'Modified to sort by argument length instead of argument value.
'Original code from: https://wellsr.com/vba/2018/excel/vba-quicksort-macro-to-sort-arrays-fast/
'Sorts a one-dimensional VBA array from smallest to largest
'using a very fast quicksort algorithm variant.
Dim pivotVal As Variant
Dim vSwap As Variant
Dim tmpLow As Long
Dim tmpHi As Long
tmpLow = arrLbound
tmpHi = arrUbound
pivotVal = vArray((arrLbound + arrUbound) \ 2)
Do While (tmpLow <= tmpHi) 'divide
Do While (Len(vArray(tmpLow)) < pivotVal And tmpLow < arrUbound)
tmpLow = tmpLow + 1
Loop
Do While (pivotVal < Len(vArray(tmpHi)) And tmpHi > arrLbound)
tmpHi = tmpHi - 1
Loop
If (tmpLow <= tmpHi) Then
vSwap = vArray(tmpLow)
vArray(tmpLow) = vArray(tmpHi)
vArray(tmpHi) = vSwap
tmpLow = tmpLow + 1
tmpHi = tmpHi - 1
End If
Loop
If (arrLbound < tmpHi) Then Quicksort__Of_StringArray_By_Length vArray, arrLbound, tmpHi 'conquer
If (tmpLow < arrUbound) Then Quicksort__Of_StringArray_By_Length vArray, tmpLow, arrUbound 'conquer
Quicksort__Of_StringArray_By_Length = vArray
End Function
Sub Test__This_Sheet_Has_At_Least_One_Formula_In_It()
MsgBox This_Sheet_Has_At_Least_One_Formula_In_It(ActiveSheet.Name)
End Sub
Function This_Sheet_Has_At_Least_One_Formula_In_It(sheetName As String)
This_Sheet_Has_At_Least_One_Formula_In_It = True
On Error GoTo Has_No_Formulas
Dim rng As Range
Set rng = Sheets(sheetName).Cells.SpecialCells(xlCellTypeFormulas)
Exit Function
Has_No_Formulas:
This_Sheet_Has_At_Least_One_Formula_In_It = False
End Function
Sub Test__Append_StringType()
ReDim sampleArray(1 To 2) As String
sampleArray(1) = "item 1"
sampleArray(2) = "item 2"
sampleArray = Append_StringType(sampleArray, "##Address_1 Line 1##")
Call MA(sampleArray)
End Sub
Function Append_StringType(arr As Variant, arg As Variant)
'Two possible errors from client subs:
'(1) arr is not of type variant.
'(2) arr is defined as Dim array() as Variant instead of ReDim array(1 to x) as variant.
Dim lowerBOundOfInputArray As Integer
lowerBOundOfInputArray = LBound(arr)
Dim upperBoundOfInputArray As Integer
upperBoundOfInputArray = UBound(arr)
ReDim newArray(lowerBOundOfInputArray To upperBoundOfInputArray) As String
newArray = arr
ReDim Preserve newArray(lowerBOundOfInputArray To upperBoundOfInputArray + 1)
newArray(upperBoundOfInputArray + 1) = arg
Append_StringType = newArray
End Function
Sub Test__SubString()
MsgBox SubString("ABCDEF", 3, 5)
End Sub
Function SubString(inputString As String, Start As Integer, Finish As Integer)
On Error GoTo Quit
SubString = Mid(inputString, Start, Finish - Start + 1)
Quit:
End Function
Sub Test__MA()
ReDim test_list(0 To 4) As Variant
test_list(0) = 45
test_list(1) = "A"
test_list(2) = 1
test_list(3) = "C"
test_list(4) = 3.14
Call MA(test_list)
End Sub
Sub MA(args As Variant)
On Error Resume Next 'In case the array to be displayed doesn't have a 0th argument.
Dim i As Integer
i = 0
Do While i <= Length(args)
MsgBox args(i)
i = i + 1
Loop
End 'Quit execution of all subs.
End Sub
Sub Test__Length()
ReDim test_list(1 To 5) As Variant
test_list(1) = "A"
test_list(2) = 1
test_list(3) = "C"
test_list(4) = 3.14
test_list(5) = 45
MsgBox Length(test_list)
End Sub
Function Length(args As Variant)
'Gives the length of an array (number of arguments).
Length = UBound(args) - LBound(args) + 1
End Function
