Option Explicit
Option Private Module
'====================================================================================================
Const rMax& = 100000        ' задаём количество элементов тестового массива
'====================================================================================================
'====================================================================================================
Sub Tester()

Dim x, tmp, arr(), arrNew(), arrNewString() As String, txt$, i&, n&, t!
Dim strCompare$, strTest$: strTest = [a3].Value2

Const delTest$ = " --- "    ' задаём разделитель для теста
Const delFin$ = "•"         ' задаём разделитель для финишной сцепки
Const nCompl As Byte = 2    ' задаём количество штатных комплектов из 100 слов и 4 букв

t = Timer
strCompare = Replace(strTest, " | ", delFin)  ' создаём контрольную строку для проверки
strTest = Replace(strTest, " | ", delTest)    ' меняем штатный разделитель " | " на заданный для теста

' собираем строку из nCompl штатных строк
ReDim arr(nCompl - 1)
    For i = 0 To UBound(arr)
        arr(i) = strTest
    Next i
strTest = Join(arr, delTest)

ReDim arr(rMax - 1)
    For i = 0 To UBound(arr)
        arr(i) = strTest
    Next i
Debug.Print "Prepare: " & Format$(1000 * (Timer - t), "0 ms")

t = Timer
    For i = 0 To UBound(arr)
'        tmp = Split(arr(i), delTest)
'        Split_Anch arr(i), delTest, arrNew
'        Split_Anch_Force arr(i), delTest, arrNew
'        Split_Mod arr(i), delTest, arrNew
        Split_Mod_Force arr(i), delTest, arrNew
'        Split_RE arr(i), delTest, arrNew
    Next i
t = 1000 * (Timer - t)
'Debug.Print LBound(arrNew) & "-" & UBound(arrNew)

    If IsArray(tmp) Then
        strTest = Join(tmp, delFin)
    Else
        strTest = Join(arrNew, delFin)
    End If

If Left$(strTest, Len(strCompare)) <> strCompare Then MsgBox "Строка собрана некорректно!", vbCritical, "COMPARE ERROR": Exit Sub
[a1].Value2 = strTest
MsgBox Format$(t, "0 ms")
End Sub
'====================================================================================================
'====================================================================================================
Sub Split_Anch(dt, del$, arr())
Dim i&, u&, nx&

u = 0: nx = 1: i = InStr(dt, del)
    Do While i
        u = u + 1
        nx = i + Len(del)
        i = InStr(nx, dt, del)
    Loop
If Len(dt) > nx Then u = u + 1
ReDim arr(1 To u): u = 0: nx = 1: i = InStr(dt, del)

    Do While i
        u = u + 1
        arr(u) = Mid$(dt, nx, i - nx)
        nx = i + Len(del)
        i = InStr(nx, dt, del)
    Loop
If Len(dt) > nx Then u = u + 1: arr(u) = Mid$(dt, nx)
End Sub
'----------------------------------------------------------------------------------------------------
Sub Split_Anch_Force(dt, del$, arr())
Dim i&, u&, nx&
Static bVBA As BedvitCOM.VBA: If bVBA Is Nothing Then Set bVBA = New BedvitCOM.VBA

u = 0: nx = 1: i = bVBA.InStr(dt, del)
    Do While i
        u = u + 1
        nx = i + Len(del)
        i = bVBA.InStr(dt, del, nx)
    Loop
If Len(dt) > nx Then u = u + 1
ReDim arr(1 To u): u = 0: nx = 1: i = bVBA.InStr(dt, del)

    Do While i
        u = u + 1
        arr(u) = Mid$(dt, nx, i - nx)
        nx = i + Len(del)
        i = bVBA.InStr(dt, del, nx)
    Loop
If Len(dt) > nx Then u = u + 1: arr(u) = Mid$(dt, nx)
End Sub
'====================================================================================================
Sub Split_Mod(dt, del$, arr())
Dim u&, i&, nx&

i = InStr(dt, del)
If i = 0 Then ReDim arr(0): arr(0) = dt: Exit Sub
ReDim arr((Len(dt) - Len(Replace(dt, del, ""))) / Len(del)): u = -1: nx = 1

    Do While i
        u = u + 1
        arr(u) = Mid$(dt, nx, i - nx)
        nx = i + Len(del)
        i = InStr(nx, dt, del)
    Loop
If Len(dt) > nx Then u = u + 1: arr(u) = Mid$(dt, nx)
End Sub
'----------------------------------------------------------------------------------------------------
Sub Split_Mod_Force(dt, del$, arr())
Dim u&, i&, nx&
Static bVBA As BedvitCOM.VBA: If bVBA Is Nothing Then Set bVBA = New BedvitCOM.VBA

i = bVBA.InStr(dt, del)
If i = 0 Then ReDim arr(0): arr(0) = dt: Exit Sub
ReDim arr((Len(dt) - Len(bVBA.Replace(dt, del, "", i))) / Len(del))
'ReDim arr(103)
u = -1: nx = 1

    Do While i
        u = u + 1
        arr(u) = Mid$(dt, nx, i - nx)
        nx = i + Len(del)
        i = bVBA.InStr(dt, del, nx)
    Loop
If Len(dt) > nx Then u = u + 1: arr(u) = Mid$(dt, nx)
End Sub
'====================================================================================================
Sub Split_RE(dt, delim$, arr1x)
Dim colMatches As MatchCollection, aMatch As Match, txt$, i&
Static re As RegExp

    If re Is Nothing Then
        Set re = New RegExp
        re.Global = True
'        re.MultiLine = True
        re.Pattern = ".+"
    End If

'txt = Replace(dt, delim, Chr(10))

    If re.Test(dt) Then
        Set colMatches = re.Execute(dt)
        ReDim arr1x(colMatches.Count - 1)
        For Each aMatch In colMatches
            arr1x(i) = aMatch: i = i + 1
        Next aMatch
    End If

End Sub
'====================================================================================================
'Sub t()
'Dim x, arr, strTest$: strTest$ = [a3].Value2
'Dim delim$: delim = " "
'
'strTest = Replace(strTest, " | ", delim)
'Split_RE strTest, delim, arr
'MsgBox TypeName(arr)
'Debug.Print LBound(arr) & "-" & UBound(arr)
'Debug.Print Join(arr, "•")
'End Sub
'====================================================================================================