Option Explicit
'===========================================================================================
Dim arr1x(), txtPhone$, colMax&, flagAbort As Boolean
Const phoneMax& = 10    ' сколько максимум номеров может быть в ячейке, то есть сколько столбцов может быть ими занято после разбивки
'===========================================================================================
Sub CutPhone()
Dim RE As New RegExp, rng As Range
Dim arr, arrNew(), r&, c&

Set rng = Intersect(Selection, ActiveSheet.UsedRange)
If rng Is Nothing Then Exit Sub
If rng.Columns.Count <> 1 Or rng.Areas.Count <> 1 Then Exit Sub
arr = rng.Value2

    If Not IsArray(arr) Then
        txtPhone = arr
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = txtPhone
    End If

ReDim arrNew(1 To UBound(arr, 1), 1 To phoneMax)
RE.Global = True
RE.Pattern = "[^0-9]"

    For r = 1 To UBound(arrNew, 1)
        txtPhone = RE.Replace(arr(r, 1), "")
        If GetPhones Then
            For c = 1 To UBound(arr1x) + 1
                arrNew(r, c) = arr1x(c - 1)
            Next c
        Else
            If flagAbort Then Exit Sub
        End If
    Next r

If colMax = 0 Then Exit Sub Else Erase arr
ReDim Preserve arrNew(1 To UBound(arrNew, 1), 1 To colMax)

Application.ScreenUpdating = False
Cells(1, rng(1).Column + 1).Resize(1, colMax).EntireColumn.Insert
Cells(rng(1).Row, rng(1).Column + 1).Resize(UBound(arrNew, 1), colMax).Value2 = arrNew
Application.ScreenUpdating = True
End Sub
'===========================================================================================
Private Function GetPhones() As Boolean
Dim ltr&, l&, ll&, i&

ll = Len(txtPhone):         If ll < 7 Then Exit Function
ReDim arr1x(phoneMax - 1):  ltr = 1: i = -1

    Do
        If Mid$(txtPhone, ltr, 1) = "0" Then Exit Do    ' если номер начинается с НОЛЯ, то это ошибка — выходим
        If Mid$(txtPhone, ltr, 1) = "8" Then
            l = ltr + 10                                ' если номер начинается с 8ки, то там должно быть 11 цифр
        Else
            l = ltr + 6                                 ' в противном случае, там должно быть 7 цифр
        End If
        
        If l > ll Then Exit Do                          ' если нужно взять больше, чем есть, то это ошибка — выходим
        
        If i + 2 > colMax Then
            colMax = i + 2
            If colMax > phoneMax Then
                MsgBox "Лимит столбцов «" & phoneMax & "» ПРЕВЫШЕН!", vbCritical, "GetPhones"
                flagAbort = True
                Exit Function
            End If
        End If
        
        i = i + 1:      arr1x(i) = Mid$(txtPhone, ltr, l - ltr + 1)
        ltr = l + 1:    If ltr > ll Then Exit Do
    Loop

If i = -1 Then Exit Function
ReDim Preserve arr1x(i): GetPhones = True
End Function
'===========================================================================================