Option Explicit
'====================================================================================================
Sub РазделитьКашуПоЧислуСТочкой()
Dim x, arr, arrNew(), rng As Range, n&, i&, l&, r&

Set rng = Selection
If rng.Columns.Count <> 1 Then MsgBox "Не более 1 СТОЛБЦА!", vbCritical, "ОШИБКА АЛГОРИТМА": Exit Sub
If rng.Areas.Count <> 1 Then MsgBox "Не более 1 ОБЛАСТИ выделения!", vbCritical, "ОШИБКА АЛГОРИТМА": Exit Sub
Set rng = Intersect(rng, ActiveSheet.UsedRange)

If rng.Count = 1 Then ReDim arr(1 To 1, 1 To 1): arr(1, 1) = rng.Value2 Else arr = rng.Value2
ReDim arrNew(1 To UBound(arr, 1), 1 To 4)

    For Each x In arr
        n = n + 1: x = Application.Trim(x): arrNew(n, 1) = x: i = InStr(2, x, ".")
        If i > 0 Then
            l = InStrRev(x, " ", i - 1)
            r = InStr(i + 1, x, " ")
            
            arrNew(n, 2) = Left$(x, l - 1)
            arrNew(n, 3) = Mid$(x, l + 1, r - l)
            arrNew(n, 4) = Mid$(x, r + 1)
        End If
    Next x

Application.ScreenUpdating = False
Cells(1, rng(1).Column + 1).Resize(1, 3).EntireColumn.Insert
rng.Resize(n, 4).Value2 = arrNew
Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
'====================================================================================================