Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Sub Test()
Dim tx$
Const sepVis& = 9553 ' separator for visual format

    If Not Rng_ToString([_rngTest], tx, vbCrLf, vbTab) Then Exit Sub

    [_clRes] = tx
    [_clShow] = Replace$(tx, vbTab, ChrW(sepVis))
    MsgBox "DONE"
End Sub
'==================================================================================================
Function Rng_ToString(rng As Range, txRes$, sepRows$, sepColumns$) As Boolean
Dim arr, tx$, i&, a&, n&, r&, c&, rr&, cc&, fR&, fC&, fChange&
Static aOne(1, 1), aData(), aRC$()

' Prepare =======================================
a = rng.Cells.Count
If a = 1 Then txRes = rng.Value: Rng_ToString = True: Exit Function
ReDim aRC(a)
ReDim aData(a)

' Main cycle ====================================
For a = 1 To rng.Areas.Count
    With rng.Areas(a)
        arr = .Value
        If Not IsArray(arr) Then aOne(1, 1) = arr: arr = aOne
        fR = .Row - 1
        fC = .Column - 1
    End With

    For c = 1 To UBound(arr, 2)
        cc = fC + c

        For r = 1 To UBound(arr, 1)
            rr = fR + r
            tx = Format$(rr, "0000000") & Format$(cc, "00000")

            n = n + 1
            aRC(n) = tx
            aData(n) = arr(r, c)

            If InStr(aData(n), sepRows) Then MsgBox "Find Rows separator «" & sepRows & "» In Value «" & arr(r, c) & "»!", vbCritical, "Rng_ToString": GoTo ex
            If InStr(aData(n), sepColumns) Then MsgBox "Find Columns separator «" & sepColumns & "» In Value «" & arr(r, c) & "»!", vbCritical, "Rng_ToString": GoTo ex
        Next r
    Next c
Next a

' Sort ==========================================
ReDim Preserve aRC(n)
ReDim Preserve aData(n)
SortRecur_a1D_SecByMain aRC, aData, 1, n

' StringCreate ==================================
txRes = aData(1)
r = Left$(aRC(1), 7)    ' cut Row from Format

For n = 2 To UBound(aRC)
    rr = Left$(aRC(n), 7)

    If rr = r Then
        txRes = txRes & sepColumns & aData(n)
    Else
        txRes = txRes & sepRows & aData(n)
        r = rr
    End If
Next n

Rng_ToString = True
ex: arr = 0: Erase aRC: Erase aData
End Function
'==================================================================================================
'==================================================================================================
Sub SortRecur_a1D_SecByMain(aMain$(), aSecondary(), LB&, UB&)
Dim x, tx$, i&, j&

i = LB: j = UB: tx = aMain((LB + UB) \ 2)

Do
    Do While aMain(i) < tx: i = i + 1: Loop
    Do While tx < aMain(j): j = j - 1: Loop
    If i <= j Then
        tx = aMain(i): aMain(i) = aMain(j): aMain(j) = tx
        x = aSecondary(i): aSecondary(i) = aSecondary(j): aSecondary(j) = x
        i = i + 1: j = j - 1
    End If
Loop Until i > j

If LB < j Then SortRecur_a1D_SecByMain aMain, aSecondary, LB, j
If i < UB Then SortRecur_a1D_SecByMain aMain, aSecondary, i, UB
End Sub