Sub dddd()
Dim mas()
Set re = CreateObject("VBScript.RegExp")
re.Global = True
re.Pattern = "[^-\s]+(?=-)"
Set mat = re.Execute(ActiveCell.Value)
For i = 1 To mat.Count
    ReDim Preserve mas(1 To i)
    mas(i) = mat(i - 1)
Next
ActiveCell.Offset(, 1).Resize(, i).Value = mas
End Sub

Option Base 1

Sub Sort1D(a1D(), lb&, UB&)
Dim i&, J&, x, y
i = lb: J = UB: x = a1D((lb + UB) / 2)
Do
    While a1D(i) < x: i = i + 1: Wend
    While x < a1D(J): J = J - 1: Wend
    If i <= J Then y = a1D(i): a1D(i) = a1D(J): a1D(J) = y: i = i + 1: J = J - 1
Loop Until i > J
If lb < J Then Sort1D a1D, lb, J
If i < UB Then Sort1D a1D, i, UB
End Sub


Sub Sort1D_ByIndexes(aV(), aI() As Long, lb&, UB&)
Dim i&, J&, n&, x, y
i = lb: J = UB: x = aV((lb + UB) \ 2)
Do
    While aV(i) < x: i = i + 1: Wend
    While x < aV(J): J = J - 1: Wend
    If i <= J Then
        y = aV(i): aV(i) = aV(J): aV(J) = y
        n = aI(i): aI(i) = aI(J): aI(J) = n
        i = i + 1: J = J - 1
    End If
Loop Until i > J
If lb < J Then Sort1D_ByIndexes aV, aI, lb, J
If i < UB Then Sort1D_ByIndexes aV, aI, i, UB
End Sub


Function Sort2D_ByIndexes(a2D, aInd() As Long) As Variant()
Dim aNew(), i&, rNew&, c&
ReDim aNew(UBound(a2D, 1), UBound(a2D, 2))
For i = LBound(aInd) To UBound(aInd)
    rNew = rNew + 1
    For c = 1 To UBound(a2D, 2)
        aNew(rNew, c) = a2D(aInd(i), c)
    Next c
Next i
Sort2D_ByIndexes = aNew
End Function


Public Function Sort2D(a2D, Optional ByVal nCol& = 1) As Variant()
Dim x, aVal(), aInd&(), r&, c&
ReDim aVal(UBound(a2D, 1)): ReDim aInd(UBound(aVal))
For r = 1 To UBound(aInd)
    aInd(r) = r: aVal(r) = a2D(r, nCol)
Next r
Sort1D_ByIndexes aVal, aInd, 1, UBound(aInd)
Sort2D = Sort2D_ByIndexes(a2D, aInd)
End Function

Sub dd45dd()
With New RegExp
    .Global = True
    .Pattern = "\S.+?\."
    Set x = .Execute(Range("A1").Value)
End With
For i = 0 To x.Count - 1
    Range("A6").Offset(i).Value = x.Item(i)
Next
End Sub

For x=1 To 5
w=Now
d=Day(w)
m=Month(w)
y=Year(w)
h=Hour(w)
n=Minute(w)
s=Second(w)
tt=y & "-" & MyF(m) & "-" & MyF(d) & " " & MyF(h) & "-" & MyF(n) & "-" & MyF(s)
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.CopyFile "D:\Основная папка\МойФайл.xlsm", "D:\Архив\МойФайл_" & tt & ".xlsm", True
Wscript.Sleep 4 * 60 * 60 * 1000
Next

Function MyF(arg)
If arg < 10 Then MyF = "0" & arg Else MyF = arg 
End Function

Set sh = CreateObject("Wscript.Shell")
sh.Run Chr(34) & "D:\1\Чистка.reg" & Chr(34), , True
Msgbox "Готово !", 64+vbSystemModal+vbMsgboxSetForeground, "БАХТИЁР"

Option Base 1

Sub SortArr1D(a1D(), lb&, UB&)
Dim i&, j&, x, y
i = lb: j = UB: x = a1D((lb + UB) \ 2)
Do
    While a1D(i) < x: i = i + 1: Wend
    While x < a1D(j): j = j - 1: Wend
    If i <= j Then y = a1D(i): a1D(i) = a1D(j): a1D(j) = y: i = i + 1: j = j - 1
Loop Until i > j
If lb < j Then SortArr1D a1D, lb, j
If i < UB Then SortArr1D a1D, i, UB
End Sub


Sub SortArr1D_ByIndexes(aV(), aI() As Long, lb&, UB&)
Dim i&, j&, n&, x, y
i = lb: j = UB: x = aV((lb + UB) \ 2)
Do
    While aV(i) < x: i = i + 1: Wend
    While x < aV(j): j = j - 1: Wend
    If i <= j Then
        y = aV(i): aV(i) = aV(j): aV(j) = y
        n = aI(i): aI(i) = aI(j): aI(j) = n
        i = i + 1: j = j - 1
    End If
Loop Until i > j
If lb < j Then SortArr1D_ByIndexes aV, aI, lb, j
If i < UB Then SortArr1D_ByIndexes aV, aI, i, UB
End Sub


Function SortArr2D_ByIndexes(a2D, aInd() As Long) As Variant()
Dim aNew(), i&, rNew&, c&
ReDim aNew(UBound(a2D, 1), UBound(a2D, 2))
For i = LBound(aInd) To UBound(aInd)
    rNew = rNew + 1
    For c = 1 To UBound(a2D, 2)
        aNew(rNew, c) = a2D(aInd(i), c)
    Next c
Next i
SortArr2D_ByIndexes = aNew
End Function


Function SortArr2D(a2D, Optional ByVal nCol& = 1) As Variant()
Dim x, aVal(), aInd&(), r&, c&
ReDim aVal(UBound(a2D, 1)): ReDim aInd(UBound(aVal))
For r = 1 To UBound(aInd)
    aInd(r) = r: aVal(r) = a2D(r, nCol)
Next r
SortArr1D_ByIndexes aVal, aInd, 1, UBound(aInd)
SortArr2D = SortArr2D_ByIndexes(a2D, aInd)
End Function