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
'==================================================================================================== |