Разбиение текста ячейки на несколько, если разделитель - цифры

Sub Разбить_по_номеру_выделенное()
    Dim i%, k%, StartChar%, TekCell As Range, S$, Z$, TekNum%, NextNum$, Block$
    For Each TekCell In Intersect(Application.Selection, ActiveSheet.UsedRange)
        Z = TekCell.Value
        If Z <> "" Then
            StartChar = 1
            For i = 2 To 40 ' 40 максимальный порядковый номер блока
                NextNum = " " & i & "."
                k = InStr(StartChar, Z, NextNum)
                If k > 0 Then
                   Block = Mid(Z, StartChar, k - StartChar)
                   StartChar = k + 1
                Else
                   Block = Mid(Z, StartChar)
                End If
                Block = Trim(Block)
                TekNum = Val(Left(Block, 3))
                TekCell.Offset(0, TekNum) = Block
            Next i
        End If
    Next TekCell
End Sub

TekCell.Offset(TekNum - 1, 0) = Block

If k = 0 Then Exit For

Sub Разбить_по_номеру()
    s = Split([a1], ". ")
    For i = 0 To UBound(s) Step 2
        Cells(i / 2 + 2, 1) = s(i) & ". " & s(i + 1) & "."
    Next
End Sub