Конвертация диапазона в одиночные адреса

Sub ConvertFormulaRangesToCells(ByVal cell As Range, ByVal sheetList As String)
    Dim i As Long, j As Long, n As Long, matches As Object, extern As Boolean
    Dim delims() As String, parts() As String, addresses() As String
    Dim ·range· As Range, ·cell· As Range, ·formula· As String
    If IsEmpty(cell) Then Exit Sub
    ·formula· = cell.FormulaR1C1
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "(" & sheetList & ")?" & Replace("~:~", "~", Replace("R~C~", "~", "(?:\d+|\[-?\d+\])?"))
        If .Test(·formula·) Then
            Set matches = .Execute(·formula·)
            delims = Split(.Replace(·formula·, "@#$"), "@#$")
            n = matches.Count
            ReDim parts(2 * n) As String
            parts(2 * n) = delims(n)
            For i = 0 To n - 1
                parts(2 * i) = delims(i)
                Set ·range· = Range(Application.ConvertFormula(matches(i), xlR1C1, Application.ReferenceStyle, , cell))
                j = 0
                extern = ·range·.Parent.Name <> cell.Parent.Name
                ReDim addresses(1 To ·range·.Count) As String
                For Each ·cell· In ·range·
                    j = j + 1
                    addresses(j) = ·cell·.Address(False, False, xlR1C1, extern, cell)
                Next ·cell·
                parts(2 * i + 1) = Join(addresses, ",")
            Next i
            cell.FormulaR1C1 = Join(parts, "")
        End If
    End With
End Sub
 
Sub DoConversion()
    Dim i As Long, n As Long, sheetNames() As String, sheetList As String, cell As Range
    n = Sheets.Count
    ReDim sheetNames(1 To n) As String
    For i = 1 To n
        sheetNames(i) = Sheets(i).Name & "!"
    Next i
    sheetList = Join(sheetNames, "|")
    For Each cell In Application.InputBox("Выберите диапазон, формулы которого надо изменить", Title:="Изменение формул", Type:=8)
        ConvertFormulaRangesToCells cell, sheetList
    Next
End Sub