Приветствую!
Решил выложить свои (и не только) решения по осуществлению задачи по замене слов в строке.
Вопрос был поднят на Планете Excel[ссылка удалена администратором], откуда я и взял шаблон[ссылка удалена администратором] для регулярки, созданный Игорем Гончаренко.
Начать нужно с определения того, что считать [отдельным] "словом": в предложенных решениях "словом" считается 1 и более [идущих подряд] символов кириллицы или латиницы.
Предложены 2 различных подхода: регулярные выражения и комплексный алгоритм на основе парсинга строки, как байтового массива. Для каждого из вариантов есть 2 версии: для замены одного "слова" и для замены "слов" по списку.
Все функции оптимизированы и очень быстрые, а также имеют опцию игнорирования регистра
Базовые необходимые проверки присутствуют.
Регулярные функции являются булевыми, а мои — возвращают количество произведённых замен.
Регулярные выражения - чрезвычайно мощный инструмент (не забываем про раннее связывание), соревноваться с которым на VBA очень тяжело. Мне удалось приблизиться к его скорости, а в некоторых тестах даже сравняться или незначительно обогнать.
Код с замерами времени
«Main». Основной модуль с тестовой процедурой и функциями замены
| Visual Basic | 1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
| Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Function TextMult(ByVal v$, Mult&, Optional ByVal Sep$ = " ") As String
Dim tx$, n&
For n = 1 To Mult
tx = tx & Sep & v
Next n
TextMult = Mid$(tx, Len(Sep) + 1)
End Function
'==================================================================================================
Private Sub Test()
Dim aFnd, aRpl
Dim tx$, res$, t!, n&, nR&
Const nCyc& = 100000, nMult& = 10 ' nMult=1 Для проверки исходной строки
tx = "Вася вас не Вас,Петя:пет;не,Пет,Alexey-alex*not«Alex»"
aFnd = Array("вас", "пет", "alex")
aRpl = Array("Василий Семёнович", "Пётр Петрович", "Jack")
' Раскомментировать, если нужно проверить
'res = tx: Debug.Print PRDX_Text_Replace_WholeWord(res, "вас", "Василий Семёнович"), res ' 1 | Вася Василий Семёнович не Вас,Петя:пет;не,Пет,Alexey-alex*not«Alex»
'res = tx: Debug.Print PRDX_Text_Replace_WholeWord(res, "пет", "Пётр Петрович", True), res ' 2 | Вася вас не Вас,Петя:Пётр Петрович;не,Пётр Петрович,Alexey-alex*not«Alex»
'res = tx: Debug.Print PRDX_Text_Replace_WholeWord_Array(res, aFnd, aRpl), res ' 3 | Вася Василий Семёнович не Вас,Петя:Пётр Петрович;не,Пет,Alexey-Jack*not«Alex»
'res = tx: Debug.Print PRDX_Text_Replace_WholeWord_Array(res, aFnd, aRpl, True), res ' 6 | Вася Василий Семёнович не Василий Семёнович,Петя:Пётр Петрович;не,Пётр Петрович,Alexey-Jack*not«Jack»
' Число замен рассчитано с помощью RE.Execute().Count. Считает некорректно. Убрал. Если оставить, то увеличивает время выполнения примерно в 2 раза.
'res = tx: Debug.Print IG_ReplaceWholeWord(res, "вас", "Василий Семёнович"), res ' 1 | Вася Василий Семёнович не Вас,Петя:пет;не,Пет,Alexey-alex*not«Alex»
'res = tx: Debug.Print IG_ReplaceWholeWord(res, "пет", "Пётр Петрович", True), res ' 2 | Вася вас не Вас,Петя:Пётр Петрович;не,Пётр Петрович,Alexey-alex*not«Alex»
'res = tx: Debug.Print IG_ReplaceWholeWord_Array(res, aFnd, aRpl), res ' 1 | Вася Василий Семёнович не Вас,Петя:Пётр Петрович;не,Пет,Alexey-Jack*not«Alex»
'res = tx: Debug.Print IG_ReplaceWholeWord_Array(res, aFnd, aRpl, True), res ' 2 | Вася Василий Семёнович не Василий Семёнович,Петя:Пётр Петрович;не,Пётр Петрович,Alexey-Jack*not«Jack»
tx = TextMult(tx, nMult)
t = Timer ' Исх. | x10
For n = 1 To nCyc / nMult
res = tx: nR = PRDX_Text_Replace_WholeWord_Array(res, aFnd, aRpl) ' 2.58 | 1.78
' res = tx: nR = PRDX_Text_Replace_WholeWord_Array(res, aFnd, aRpl, True) ' 2.89 | 1.97
' res = tx: nR = IG_ReplaceWholeWord_Array(res, aFnd, aRpl) ' 2.64 | 1,48
' res = tx: nR = IG_ReplaceWholeWord_Array(res, aFnd, aRpl, True) ' 2,98 | 1.66
Next n
Debug.Print Format$(Timer - t, "0.00"), nR
End Sub
'==================================================================================================
'==================================================================================================
Function PRDX_Text_Replace_WholeWord(tmpString, ByVal iFnd$, ByVal iRpl$, Optional CaseIgnore As Boolean) As Long
Dim aWrd$(), aSep$()
Dim n&, nRpl&
If Not LCase$(tmpString) Like "*[a-zёа-я]*" Then Exit Function
If Not PRDX_SplitString_ByNonCyrLat(tmpString, aWrd, aSep) Then Stop: End
If CaseIgnore Then
iFnd = LCase$(iFnd)
For n = 1 To UBound(aWrd)
If iFnd = LCase$(aWrd(n)) Then nRpl = nRpl + 1: aWrd(n) = iRpl
Next n
Else
For n = 1 To UBound(aWrd)
If iFnd = aWrd(n) Then nRpl = nRpl + 1: aWrd(n) = iRpl
Next n
End If
If nRpl Then PRDX_Text_Replace_WholeWord = nRpl Else Exit Function
tmpString = PRDX_SplitString_ByNonCyrLat_Join(aWrd, aSep)
End Function
'==================================================================================================
Function PRDX_Text_Replace_WholeWord_Array(tmpString, aFind, aRpl, Optional CaseIgnore As Boolean) As Long
Dim aWrd$(), aSep$()
Dim tx$, f&, n&, nRpl&
Static st&, dic As Dictionary
If Not LCase$(tmpString) Like "*[a-zёа-я]*" Then Exit Function
If st = 0 Then st = 1: Set dic = New Dictionary
If Not PRDX_SplitString_ByNonCyrLat(tmpString, aWrd, aSep) Then Stop: End
If CaseIgnore Then
For n = LBound(aFind) To UBound(aFind)
tx = LCase$(aFind(n))
If Not dic.Exists(tx) Then dic.Add tx, aRpl(n)
Next n
For n = 1 To UBound(aWrd)
tx = LCase$(aWrd(n))
If dic.Exists(tx) Then nRpl = nRpl + 1: aWrd(n) = dic(tx)
Next n
Else
For n = LBound(aFind) To UBound(aFind)
tx = aFind(n)
If Not dic.Exists(tx) Then dic.Add tx, aRpl(n)
Next n
For n = 1 To UBound(aWrd)
If dic.Exists(aWrd(n)) Then nRpl = nRpl + 1: aWrd(n) = dic(aWrd(n))
Next n
End If
dic.RemoveAll
If nRpl Then PRDX_Text_Replace_WholeWord_Array = nRpl Else Exit Function
tmpString = PRDX_SplitString_ByNonCyrLat_Join(aWrd, aSep)
End Function
'==================================================================================================
'==================================================================================================
Function IG_ReplaceWholeWord(tmpString, ByVal iFnd$, ByVal iRpl$, Optional CaseIgnore As Boolean) As Boolean
Dim x, tx$
Static st&, RE As RegExp, REci As RegExp
If st = 0 Then
st = 1
Set RE = New RegExp: RE.Global = True
Set REci = New RegExp: REci.Global = True: REci.IgnoreCase = True
End If
If CaseIgnore Then
tx = "(^|[^a-zа-яё])" & iFnd & "(?=[^a-zа-яё]|$)"
If REci.Pattern <> tx Then REci.Pattern = tx
If REci.Test(tmpString) Then IG_ReplaceWholeWord = True Else Exit Function
tmpString = REci.Replace(tmpString, "$1" & iRpl)
Else
tx = "(^|[^A-Za-zА-яЁё])" & iFnd & "(?=[^A-Za-zА-яЁё]|$)"
If RE.Pattern <> tx Then RE.Pattern = tx
If RE.Test(tmpString) Then IG_ReplaceWholeWord = True Else Exit Function
tmpString = RE.Replace(tmpString, "$1" & iRpl)
End If
End Function
'==================================================================================================
Function IG_ReplaceWholeWord_Array(tmpString, aFind, aRpl, Optional CaseIgnore As Boolean) As Boolean
Dim x, n&
Static st&, RE As RegExp, REci As RegExp
If st = 0 Then
st = 1
Set RE = New RegExp: RE.Global = True
Set REci = New RegExp: REci.Global = True: REci.IgnoreCase = True
End If
If CaseIgnore Then
For n = LBound(aFind) To UBound(aFind)
REci.Pattern = "(^|[^a-zа-яё])" & aFind(n) & "(?=[^a-zа-яё]|$)"
If REci.Test(tmpString) Then IG_ReplaceWholeWord_Array = True Else Exit Function
tmpString = REci.Replace(tmpString, "$1" & aRpl(n))
Next n
Else
For n = LBound(aFind) To UBound(aFind)
RE.Pattern = "(^|[^A-Za-zА-яЁё])" & aFind(n) & "(?=[^A-Za-zА-яЁё]|$)"
If RE.Test(tmpString) Then IG_ReplaceWholeWord_Array = True Else Exit Function
tmpString = RE.Replace(tmpString, "$1" & aRpl(n))
Next n
End If
End Function |
|
Модуль «AscW_Check». Функция определения принадлежности символа по его коду AscW к кириллице или латинице
| Visual Basic | 1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
| Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
' Num: 48-57
' Lat: 65-90; 97-122
' Cyr: 1025; 1040-1103; 1105
'==================================================================================================
'==================================================================================================
'==================================================================================================
Function PRDX_AscW_CyrAndLat_GetArr() As Long()
Dim a&(1105), s&
For s = 65 To 1105
Select Case s
Case 91: s = 97
Case 123: s = 1025
Case 1026: s = 1040
Case 1104: s = 1105
End Select
a(s) = 1
Next s
PRDX_AscW_CyrAndLat_GetArr = a
End Function
'==================================================================================================
Function PRDX_AscW_CyrAndLat_Is(iAscW&) As Boolean
Static st&, a&()
If iAscW > 1105 Then Exit Function
If st = 0 Then st = 1: a = PRDX_AscW_CyrAndLat_GetArr()
If a(iAscW) Then PRDX_AscW_CyrAndLat_Is = True
End Function |
|
Модуль «Splitter». Получение из строки 2ух массивов: слова и неслова
| Visual Basic | 1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
| Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Private Sub Test_PRDX_SplitString_ByNonCyrLat()
Dim x, w$(), s$(), n&
x = ",./asd.gh./*красота/*b./7jg,,./"
If Not PRDX_SplitString_ByNonCyrLat(x, w, s) Then Exit Sub
For n = 1 To UBound(s)
Debug.Print "«" & s(n) & "»"
If n < UBound(s) Then Debug.Print "«" & w(n) & "»"
Next n
Debug.Print x = PRDX_SplitString_ByNonCyrLat_Join(w, s)
End Sub
'==================================================================================================
'==================================================================================================
' Fill aWrd(N) and aSep(N+1)
Function PRDX_SplitString_ByNonCyrLat(ByVal iStr$, aWrd$(), aSep$()) As Boolean
Dim aBt() As Byte
Dim i&, n&, nW&, nS&, bW&, bS&
aBt = iStr
ReDim aWrd(Len(iStr))
ReDim aSep(UBound(aWrd))
For i = 0 To UBound(aBt) Step 2
n = n + 1
If PRDX_AscW_CyrAndLat_Is(aBt(i) + 256 * aBt(i + 1)) Then ' Ltr
If bW Then GoTo nx Else bW = n
If bS = 0 Then
If nS = 0 Then nS = nS + 1: aSep(nS) = ""
GoTo nx
End If
nS = nS + 1: aSep(nS) = Mid$(iStr, bS, n - bS): bS = 0
Else ' NonLtr
If bS Then GoTo nx Else bS = n
If bW = 0 Then GoTo nx
nW = nW + 1: aWrd(nW) = Mid$(iStr, bW, n - bW): bW = 0
End If
nx:
Next i
If bW Then
nW = nW + 1: aWrd(nW) = Mid$(iStr, bW)
Else
nS = nS + 1: aSep(nS) = Mid$(iStr, bS)
End If
If nW = 0 Then Stop: End
If nS < nW Then Stop: End
If nS > nW + 1 Then Stop: End
If nS = nW Then nS = nS + 1: aSep(nS) = ""
ReDim Preserve aWrd(nW)
ReDim Preserve aSep(nS)
PRDX_SplitString_ByNonCyrLat = True
End Function
'==================================================================================================
Function PRDX_SplitString_ByNonCyrLat_Join(aWrd$(), aSep$()) As String
Dim tx$, n&
For n = 1 To UBound(aWrd)
tx = tx & aSep(n) & aWrd(n)
Next n
PRDX_SplitString_ByNonCyrLat_Join = tx & aSep(UBound(aSep))
End Function
'================================================================================================== |
|
Алгоритм НЕрегулярного варианта
1. Берём строку в байтовый массив.
2. В цикле по байтам определяем принадлежность очередного символа к кириллице или латинице.
3. Собираем 2 массива ("слов" и "неслов") в порядке их расположения в строке. Массив НЕслов ВСЕГДА на 1 больше, чем массив слов. Сделано это для однозначности - отдельная функция сцепляет эти массивы обратно в строку, беря 1ый элемент массива "НЕслов", прибавляя к нему 1ый элемент массива "слов" и так далее, пока массив "слов" не кончится. В конце добавляем гарантированно оставшийся элемент массива "НЕслов". Если строка начинается/заканчивается с символа "НЕслова", то будут они, если первым/последним символом является "слово", то в массиве "НЕслов" будут строки нолевой длины "".
4. Функции замены остаётся только пробежаться по массиву "слов", произвести замены и сцепить 2 массива обратно в строку
UPD 2023/01/09: Обновление. Выше не правил.
• Обновил старую функцию (~ 15%), добавив проверку длины первого и последнего разделителя.
• Сделал новую функцию сцепки массивов "слов-неслов" обратно в строку (быстрее обновлённой старой на ~30%).
• Сделал функцию сцепки с помощью Join'а (~ 2x медленнее новой).
• Сделал процедуру сравнения всех этих 3ёх вариантов.
Важно:
• для работы новой функции нужна длина новой строки (чем длиннее строка, тем больше будет выигрыш).
• если встроить [а не вызывать отдельно] сбор строки старым методом "в лоб" в функцию замены слов [в цикл замены], то может быть быстрее, чем собирать длину строки и запускать новую функцию отдельно.
Код
| Visual Basic | 1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
| Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Function PRDX_SplitString_ByNonCyrLat_Join(aWrd$(), aSep$(), iLen&) As String
Dim tx$, n&, p&, l&
tx = String$(iLen, " "): p = 1
l = Len(aSep(1))
If l Then Mid$(tx, p, l) = aSep(1): p = p + l
l = Len(aWrd(1)): Mid$(tx, p, l) = aWrd(1): p = p + l
For n = 2 To UBound(aWrd)
l = Len(aSep(n)): Mid$(tx, p, l) = aSep(n): p = p + l
l = Len(aWrd(n)): Mid$(tx, p, l) = aWrd(n): p = p + l
Next n
l = Len(aSep(n))
If l Then Mid$(tx, p, l) = aSep(n)
PRDX_SplitString_ByNonCyrLat_Join = tx
End Function
'--------------------------------------------------------------------------------------------------
Function PRDX_SplitString_ByNonCyrLat_Join2(aWrd$(), aSep$()) As String
Dim tx$, n&
If Len(aSep(1)) Then
tx = aSep(1) & aWrd(1)
Else
tx = aWrd(1)
End If
For n = 2 To UBound(aWrd)
tx = tx & aSep(n) & aWrd(n)
Next n
If Len(aSep(n)) Then
PRDX_SplitString_ByNonCyrLat_Join2 = tx & aSep(n)
Else
PRDX_SplitString_ByNonCyrLat_Join2 = tx
End If
End Function
'--------------------------------------------------------------------------------------------------
Function PRDX_SplitString_ByNonCyrLat_Join3(aWrd$(), aSep$()) As String
Dim a$(), tx$, n&, j&
n = UBound(aWrd) + UBound(aSep)
If Len(aSep(1)) Then
If Len(aSep(UBound(aSep))) Then
ReDim a(n)
For n = 1 To UBound(aWrd)
j = j + 1: a(j) = aSep(n)
j = j + 1: a(j) = aWrd(n)
Next n
j = j + 1: a(j) = aSep(n)
Else
ReDim a(n - 1)
For n = 1 To UBound(aWrd)
j = j + 1: a(j) = aSep(n)
j = j + 1: a(j) = aWrd(n)
Next n
End If
Else
If Len(aSep(UBound(aSep))) Then
ReDim a(n - 1)
j = j + 1: a(j) = aWrd(1)
For n = 2 To UBound(aWrd)
j = j + 1: a(j) = aSep(n)
j = j + 1: a(j) = aWrd(n)
Next n
j = j + 1: a(j) = aSep(n)
Else
ReDim a(n - 2)
j = j + 1: a(j) = aWrd(1)
For n = 2 To UBound(aWrd)
j = j + 1: a(j) = aSep(n)
j = j + 1: a(j) = aWrd(n)
Next n
End If
End If
PRDX_SplitString_ByNonCyrLat_Join3 = Join(a, "")
End Function
'==================================================================================================
Private Sub Test_PRDX_SplitString_ByNonCyrLat_Join()
Dim tx$, w$(), s$()
Dim res$, t!, n&, l&
tx = "asd.gh7jg.sdfsddf.234sfd.sdfs sdfsdfjjkl"
tx = "." & tx & "." ' UnComment for .*.
l = Len(tx)
If Not PRDX_SplitString_ByNonCyrLat(tx, w, s) Then Exit Sub
t = Timer
For n = 1 To 1000000 ' * / .*.
' res = PRDX_SplitString_ByNonCyrLat_Join(w, s, l) ' 0.72 / 0.77
' res = PRDX_SplitString_ByNonCyrLat_Join2(w, s) ' 0.96 / 1.02
' res = PRDX_SplitString_ByNonCyrLat_Join3(w, s) ' 1.71 / 1.95
Next n
Debug.Print Format$(Timer - t, "0.00"), res = tx, "«" & res & "»"
End Sub |
|
Продолжение. Тесты показали, что встраивать в цикл смысла нет, а вот новая функция заметно ускоряет весь процесс
| Visual Basic | 1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
| Private Sub Test()
Dim tx$, res$, t!, n&, nR&
Const nCyc& = 100000, nMult& = 10 ' nMult=1 Для проверки исходной строки
tx = "Вася вас не Вас,Петя:пет;не,Пет,Alexey-alex*not«Alex»"
' Раскомментировать, если нужно проверить
'res = tx: Debug.Print PRDX_Text_Replace_WholeWord(res, "вас", "Василий Семёнович"), res ' 1 | Вася Василий Семёнович не Вас,Петя:пет;не,Пет,Alexey-alex*not«Alex»
'res = tx: Debug.Print PRDX_Text_Replace_WholeWord(res, "пет", "Пётр Петрович", True), res ' 2 | Вася вас не Вас,Петя:Пётр Петрович;не,Пётр Петрович,Alexey-alex*not«Alex»
'res = tx: Debug.Print PRDX_Text_Replace_WholeWord_OneCycle(res, "вас", "Василий Семёнович"), res ' 1 | Вася Василий Семёнович не Вас,Петя:пет;не,Пет,Alexey-alex*not«Alex»
'res = tx: Debug.Print PRDX_Text_Replace_WholeWord_OneCycle(res, "пет", "Пётр Петрович", True), res ' 2 | Вася вас не Вас,Петя:Пётр Петрович;не,Пётр Петрович,Alexey-alex*not«Alex»
'res = tx: Debug.Print PRDX_Text_Replace_WholeWord_Mid(res, "вас", "Василий Семёнович"), res ' 1 | Вася Василий Семёнович не Вас,Петя:пет;не,Пет,Alexey-alex*not«Alex»
'res = tx: Debug.Print PRDX_Text_Replace_WholeWord_Mid(res, "пет", "Пётр Петрович", True), res ' 2 | Вася вас не Вас,Петя:Пётр Петрович;не,Пётр Петрович,Alexey-alex*not«Alex»
tx = PRDX_Text_Mult(tx, nMult)
t = Timer ' Исх. | x10
For n = 1 To nCyc / nMult
' res = tx: nR = PRDX_Text_Replace_WholeWord(res, "вас", "Василий Семёнович") ' 1.72 | 1.64
' res = tx: nR = PRDX_Text_Replace_WholeWord_OneCycle(res, "вас", "Василий Семёнович") ' 1.72 | 1.67
' res = tx: nR = PRDX_Text_Replace_WholeWord_Mid(res, "вас", "Василий Семёнович") ' 1.69 | 1.53
Next n
Debug.Print Format$(Timer - t, "0.00"), nR
End Sub
'==================================================================================================
'==================================================================================================
Function PRDX_Text_Replace_WholeWord(tmpString, ByVal iFnd$, ByVal iRpl$, Optional CaseIgnore As Boolean) As Long
Dim aWrd$(), aSep$()
Dim n&, nRpl&
If Not PRDX_SplitString_ByNonCyrLat(tmpString, aWrd, aSep) Then Stop: End
If CaseIgnore Then
iFnd = LCase$(iFnd)
For n = 1 To UBound(aWrd)
If iFnd = LCase$(aWrd(n)) Then nRpl = nRpl + 1: aWrd(n) = iRpl
Next n
Else
For n = 1 To UBound(aWrd)
If iFnd = aWrd(n) Then nRpl = nRpl + 1: aWrd(n) = iRpl
Next n
End If
If nRpl Then PRDX_Text_Replace_WholeWord = nRpl Else Exit Function
tmpString = PRDX_SplitString_ByNonCyrLat_Join2(aWrd, aSep)
End Function
'--------------------------------------------------------------------------------------------------
Function PRDX_Text_Replace_WholeWord_OneCycle(tmpString, ByVal iFnd$, ByVal iRpl$, Optional CaseIgnore As Boolean) As Long
Dim aWrd$(), aSep$()
Dim res$, n&, nRpl&
If Not PRDX_SplitString_ByNonCyrLat(tmpString, aWrd, aSep) Then Stop: End
If CaseIgnore Then
iFnd = LCase$(iFnd)
If iFnd = LCase$(aWrd(1)) Then nRpl = nRpl + 1: aWrd(1) = iRpl
If Len(aSep(1)) Then res = aSep(1) & aWrd(1) Else res = aWrd(1)
For n = 2 To UBound(aWrd)
If iFnd = LCase$(aWrd(n)) Then nRpl = nRpl + 1: aWrd(n) = iRpl
res = res & aSep(n) & aWrd(n)
Next n
Else
If iFnd = aWrd(1) Then nRpl = nRpl + 1: aWrd(1) = iRpl
If Len(aSep(1)) Then res = aSep(1) & aWrd(1) Else res = aWrd(1)
For n = 2 To UBound(aWrd)
If iFnd = aWrd(n) Then nRpl = nRpl + 1: aWrd(n) = iRpl
res = res & aSep(n) & aWrd(n)
Next n
End If
If nRpl Then PRDX_Text_Replace_WholeWord_OneCycle = nRpl Else Exit Function
If Len(aSep(n)) Then tmpString = res & aSep(n) Else tmpString = res
End Function
'--------------------------------------------------------------------------------------------------
Function PRDX_Text_Replace_WholeWord_Mid(tmpString, ByVal iFnd$, ByVal iRpl$, Optional CaseIgnore As Boolean) As Long
Dim aWrd$(), aSep$()
Dim n&, nRpl&, l&
If Not PRDX_SplitString_ByNonCyrLat(tmpString, aWrd, aSep) Then Stop: End
If CaseIgnore Then
iFnd = LCase$(iFnd)
For n = 1 To UBound(aWrd)
If iFnd = LCase$(aWrd(n)) Then nRpl = nRpl + 1: aWrd(n) = iRpl
l = l + Len(aSep(n)) + Len(aWrd(n))
Next n
Else
For n = 1 To UBound(aWrd)
If iFnd = aWrd(n) Then nRpl = nRpl + 1: aWrd(n) = iRpl
l = l + Len(aSep(n)) + Len(aWrd(n))
Next n
End If
If nRpl Then PRDX_Text_Replace_WholeWord_Mid = nRpl Else Exit Function
l = l + Len(aSep(n)): tmpString = PRDX_SplitString_ByNonCyrLat_Join(aWrd, aSep, l)
End Function |
|
UPD 2023/01/10: Идея ускорения. Тест сцепок.
Есть идея вместо 2ух массивов делать один. Тест штатной сцепки одного стрингнового массива Join'ом показывает, что он кратно выигрывает у самого быстрого метода сцепки 2ух массивов. При условии, что все массивы определены и наполнены ПЕРЕД циклом проверки сцепки.
Это означает, что идея имеет реальный смысл, если скорость получения ОДНОГО массива не будет ниже скорости получения 2ух (а этого и не случится - даже наоборот). Бонусом будет то, что не будет необходимости иметь массив НЕслов всегда больше на 1, чем массив слов (обрамляющий массив), а значит, скорость [на 2ух этапах: разбивка в массив и склейка обратно] будет ещё выше. Продолжаю. | Visual Basic | 1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
| Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Function PRDX_SplitString_ByNonCyrLat_Join(aWrd$(), aSep$(), iLen&) As String
Dim tx$, n&, p&, l&
tx = String$(iLen, " "): p = 1
l = Len(aSep(1))
If l Then Mid$(tx, p, l) = aSep(1): p = p + l
l = Len(aWrd(1)): Mid$(tx, p, l) = aWrd(1): p = p + l
For n = 2 To UBound(aWrd)
l = Len(aSep(n)): Mid$(tx, p, l) = aSep(n): p = p + l
l = Len(aWrd(n)): Mid$(tx, p, l) = aWrd(n): p = p + l
Next n
l = Len(aSep(n))
If l Then Mid$(tx, p, l) = aSep(n)
PRDX_SplitString_ByNonCyrLat_Join = tx
End Function
'==================================================================================================
Private Sub TestJoin()
Dim x, a$(3), aSep$(), aWrd$(), aFull$()
Dim tx$, res$, t!, n&, j&
a(1) = "мама"
a(2) = "мама мыла Милу с мылом"
a(3) = a(2) & "•" & a(2) & "•" & a(2) & "•" & a(2) & "•" & a(2)
tx = a(2)
If Not PRDX_SplitString_ByNonCyrLat(tx, aWrd, aSep) Then Stop: End
ReDim aFull(UBound(aWrd) + UBound(aSep))
For n = 1 To UBound(aWrd)
j = j + 1: aFull(j) = aSep(n)
j = j + 1: aFull(j) = aWrd(n)
Next n
j = j + 1: aFull(j) = aSep(n)
t = Timer
For n = 1 To 1000000 ' 1 2 3
' res = PRDX_SplitString_ByNonCyrLat_Join(aWrd, aSep, Len(tx)) ' 0.32 | 0.61 | 1.91
' res = Join(aFull, "") ' 0.15 | 0.22 | 0.61
Next n
Debug.Print Format$(Timer - t, "0.00"), tx = res
End Sub |
|
Продолжение. Тест массивов для индикации брать/не брать [очередной элемент]
Несмотря на то, что переменная Long(4 байта) незначительно, но быстрее Boolean(2 байта) и Byte(1 байт) — в плане определения очередного элемента массива на да/нет, 0/1, False/True побеждает булевый массив. Integer даже не рассматривал (и не использую) - он ещё на тестах переменных проиграл Long'у.
Бонус тест: определение Long и Byte элемента, как If a(n)=1 Then или If a(n)<>0 Then немного быстрее короткой записи If a(n) Then, а с Boolean всё с точностью, но наоборот.  | Visual Basic | 1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
| Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Private Sub TestArr()
Dim aLn() As Long, aBl() As Boolean, aBt() As Byte
Dim t!, n&, e&, p&
Const nEl& = 1000000, nCyc& = 100
ReDim aLn(nEl)
ReDim aBl(nEl)
ReDim aBt(nEl)
For n = 1 To nEl Step 2
aLn(n) = 1
aBl(n) = True
aBt(n) = 1
Next n
t = Timer
For n = 1 To nCyc ' =1/=-1 | <> 0 | Short
For e = 1 To nEl
' If aLn(n) = 1 Then p = p + 1 ' 1.38 | 1.38 | 1.58
' If aBl(n) Then p = p + 1 ' 1.38 | 1.38 | 1.21
' If aBt(n) = 1 Then p = p + 1 ' 1.38 | 1.38 | 1.55
Next e
Next n
Debug.Print Format$(Timer - t, "0.00"), "Check", p
End Sub |
|
Продолжение. Новый, более быстрый, вариант
Сделал много тестов. Они показывают, что новый метод деления строки НЕмедленнее (незаметно быстрее) старого, зато сцепка штатным Join'ом [в этом случае, когда массив для сцепки не нужно готовить] быстрее предыдущего самого быстрого метода [с помощью наполнения буферной строки через Mid$()] около 3ёх раз.
Отрыв от регулярок на нормальных строках (53 символа, замена 3ёх или 6ти "слов") стал ещё больше: ~ 45%
На сверхдлинных строках (530 символов, замена 30ти или 60ти "слов") регулярки всё-ещё немного опережают: ~ 3%
Также добавлены варианты, когда в функцию замены передаётся словарь, а не массив ("_Fast") — это демонстрационный вариант для данного теста. В реальной ситуации, он не нужен (но работать будет - просто наполнение словаря вынесено из функции наружу). Видимый прирост скорости только на "нормальных" строках: ~ 10%
Код
Модуль «Main»
| Visual Basic | 1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
| Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Function TextMult(ByVal v$, Mult&, Optional ByVal Sep$ = " ") As String
Dim tx$, n&
For n = 1 To Mult
tx = tx & Sep & v
Next n
TextMult = Mid$(tx, Len(Sep) + 1)
End Function
'==================================================================================================
Private Sub Test()
Dim aFnd, aRpl
Dim dic As New Dictionary, dicCI As New Dictionary
Dim tx$, res$, t!, n&, nR&
Const nCyc& = 100000, nMult& = 10 ' nMult=1 Для проверки исходной строки
tx = "Вася вас не Вас,Петя:пет;не,Пет,Alexey-alex*not«Alex»"
aFnd = Array("вас", "пет", "alex")
aRpl = Array("Василий Семёнович", "Пётр Петрович", "Jack")
For n = 1 To UBound(aFnd)
dic.Add aFnd(n), aRpl(n)
dicCI.Add LCase$(aFnd(n)), aRpl(n)
Next n
tx = TextMult(tx, nMult)
t = Timer ' Исх. | x10
For n = 1 To nCyc / nMult
' res = tx: nR = PRDX_Text_Replace_WholeWord_Array_Fast(res, dic) ' 1.66 | 1.53
' res = tx: nR = PRDX_Text_Replace_WholeWord_Array_Fast(res, dicCI, True) ' 1.78 | 1.69
' res = tx: nR = PRDX_Text_Replace_WholeWord_Array(res, aFnd, aRpl) ' 1.86 | 1.55
' res = tx: nR = PRDX_Text_Replace_WholeWord_Array(res, aFnd, aRpl, True) ' 2.05 | 1.71
' res = tx: nR = PRDX_Text_Replace_WholeWord_Array_Old(res, aFnd, aRpl) ' 2.04 | 1.65
' res = tx: nR = PRDX_Text_Replace_WholeWord_Array_Old(res, aFnd, aRpl, True) ' 2.22 | 1.82
' res = tx: nR = IG_ReplaceWholeWord_Array(res, aFnd, aRpl) ' 2.64 | 1,48
' res = tx: nR = IG_ReplaceWholeWord_Array(res, aFnd, aRpl, True) ' 2,98 | 1.66
Next n
Debug.Print Format$(Timer - t, "0.00"), nR
End Sub
'==================================================================================================
'==================================================================================================
Function PRDX_Text_Replace_WholeWord(tmpString, ByVal iFnd$, ByVal iRpl$, Optional CaseIgnore As Boolean, Optional MsgFalse As Boolean) As Long
Dim aP$(), aI&()
Dim n&, nRpl&
If Not PRDX_SplitString_ByNonCyrLat(tmpString, aP, aI, MsgFalse) Then Exit Function
If CaseIgnore Then
iFnd = LCase$(iFnd)
For n = 1 To UBound(aI)
If iFnd = LCase$(aP(aI(n))) Then nRpl = nRpl + 1: aP(aI(n)) = iRpl
Next n
Else
For n = 1 To UBound(aI)
If iFnd = aP(aI(n)) Then nRpl = nRpl + 1: aP(aI(n)) = iRpl
Next n
End If
If nRpl = 0 Then Exit Function
PRDX_Text_Replace_WholeWord = nRpl: tmpString = Join(aP, "")
End Function
'==================================================================================================
Function PRDX_Text_Replace_WholeWord_Array(tmpString, aFind, aRpl, Optional CaseIgnore As Boolean, Optional MsgFalse As Boolean) As Long
Dim aP$(), aI&()
Dim tx$, f&, n&, nRpl&
Static st&, dic As Dictionary
If st = 0 Then st = 1: Set dic = New Dictionary
If Not PRDX_SplitString_ByNonCyrLat(tmpString, aP, aI, MsgFalse) Then Exit Function
If CaseIgnore Then
For n = LBound(aFind) To UBound(aFind)
dic.Add LCase$(aFind(n)), aRpl(n)
Next n
For n = 1 To UBound(aI)
tx = LCase$(aP(aI(n)))
If dic.Exists(tx) Then nRpl = nRpl + 1: aP(aI(n)) = dic(tx)
Next n
Else
For n = LBound(aFind) To UBound(aFind)
dic.Add aFind(n), aRpl(n)
Next n
For n = 1 To UBound(aI)
If dic.Exists(aP(aI(n))) Then nRpl = nRpl + 1: aP(aI(n)) = dic(tx)
Next n
End If
dic.RemoveAll
If nRpl = 0 Then Exit Function
PRDX_Text_Replace_WholeWord_Array = nRpl: tmpString = Join(aP, "")
End Function
'==================================================================================================
Function PRDX_Text_Replace_WholeWord_Array_Fast(tmpString, dic As Dictionary, Optional CaseIgnore As Boolean, Optional MsgFalse As Boolean) As Long
Dim aP$(), aI&()
Dim tx$, f&, n&, nRpl&
If Not PRDX_SplitString_ByNonCyrLat(tmpString, aP, aI, MsgFalse) Then Exit Function
If CaseIgnore Then
For n = 1 To UBound(aI)
tx = LCase$(aP(aI(n)))
If dic.Exists(tx) Then nRpl = nRpl + 1: aP(aI(n)) = dic(tx)
Next n
Else
For n = 1 To UBound(aI)
If dic.Exists(aP(aI(n))) Then nRpl = nRpl + 1: aP(aI(n)) = dic(tx)
Next n
End If
If nRpl = 0 Then Exit Function
PRDX_Text_Replace_WholeWord_Array_Fast = nRpl: tmpString = Join(aP, "")
End Function
'==================================================================================================
'==================================================================================================
Function PRDX_Text_Replace_WholeWord_Old(tmpString, ByVal iFnd$, ByVal iRpl$, Optional CaseIgnore As Boolean) As Long
Dim aWrd$(), aSep$()
Dim n&, l&, nRpl&
If Not LCase$(tmpString) Like "*[a-zёа-я]*" Then Exit Function
If Not PRDX_SplitString_ByNonCyrLat_Old(tmpString, aWrd, aSep) Then Stop: End
If CaseIgnore Then
iFnd = LCase$(iFnd)
For n = 1 To UBound(aWrd)
If iFnd = LCase$(aWrd(n)) Then nRpl = nRpl + 1: aWrd(n) = iRpl
l = l + Len(aWrd(n)) + Len(aSep(n))
Next n
Else
For n = 1 To UBound(aWrd)
If iFnd = aWrd(n) Then nRpl = nRpl + 1: aWrd(n) = iRpl
l = l + Len(aWrd(n)) + Len(aSep(n))
Next n
End If
If nRpl = 0 Then Exit Function
PRDX_Text_Replace_WholeWord_Old = nRpl
l = l + Len(aSep(n)): tmpString = PRDX_SplitString_ByNonCyrLat_Join(aWrd, aSep, l)
End Function
'==================================================================================================
Function PRDX_Text_Replace_WholeWord_Array_Old(tmpString, aFind, aRpl, Optional CaseIgnore As Boolean) As Long
Dim aWrd$(), aSep$()
Dim tx$, f&, n&, l&, nRpl&
Static st&, dic As Dictionary
If Not LCase$(tmpString) Like "*[a-zёа-я]*" Then Exit Function
If st = 0 Then st = 1: Set dic = New Dictionary
If Not PRDX_SplitString_ByNonCyrLat_Old(tmpString, aWrd, aSep) Then Stop: End
If CaseIgnore Then
For n = LBound(aFind) To UBound(aFind)
tx = LCase$(aFind(n))
If Not dic.Exists(tx) Then dic.Add tx, aRpl(n)
Next n
For n = 1 To UBound(aWrd)
tx = LCase$(aWrd(n))
If dic.Exists(tx) Then nRpl = nRpl + 1: aWrd(n) = dic(tx)
l = l + Len(aWrd(n)) + Len(aSep(n))
Next n
Else
For n = LBound(aFind) To UBound(aFind)
tx = aFind(n)
If Not dic.Exists(tx) Then dic.Add tx, aRpl(n)
Next n
For n = 1 To UBound(aWrd)
If dic.Exists(aWrd(n)) Then nRpl = nRpl + 1: aWrd(n) = dic(aWrd(n))
l = l + Len(aWrd(n)) + Len(aSep(n))
Next n
End If
dic.RemoveAll
If nRpl = 0 Then Exit Function
PRDX_Text_Replace_WholeWord_Array_Old = nRpl
l = l + Len(aSep(n)): tmpString = PRDX_SplitString_ByNonCyrLat_Join(aWrd, aSep, l)
End Function
'==================================================================================================
'==================================================================================================
Function IG_ReplaceWholeWord(tmpString, ByVal iFnd$, ByVal iRpl$, Optional CaseIgnore As Boolean) As Boolean
Dim x, tx$
Static st&, RE As RegExp, REci As RegExp
If st = 0 Then
st = 1
Set RE = New RegExp: RE.Global = True
Set REci = New RegExp: REci.Global = True: REci.IgnoreCase = True
End If
If CaseIgnore Then
tx = "(^|[^a-zа-яё])" & iFnd & "(?=[^a-zа-яё]|$)"
If REci.Pattern <> tx Then REci.Pattern = tx
If REci.Test(tmpString) Then IG_ReplaceWholeWord = True Else Exit Function
tmpString = REci.Replace(tmpString, "$1" & iRpl)
Else
tx = "(^|[^A-Za-zА-яЁё])" & iFnd & "(?=[^A-Za-zА-яЁё]|$)"
If RE.Pattern <> tx Then RE.Pattern = tx
If RE.Test(tmpString) Then IG_ReplaceWholeWord = True Else Exit Function
tmpString = RE.Replace(tmpString, "$1" & iRpl)
End If
End Function
'==================================================================================================
Function IG_ReplaceWholeWord_Array(tmpString, aFind, aRpl, Optional CaseIgnore As Boolean) As Boolean
Dim x, n&
Static st&, RE As RegExp, REci As RegExp
If st = 0 Then
st = 1
Set RE = New RegExp: RE.Global = True
Set REci = New RegExp: REci.Global = True: REci.IgnoreCase = True
End If
If CaseIgnore Then
For n = LBound(aFind) To UBound(aFind)
REci.Pattern = "(^|[^a-zа-яё])" & aFind(n) & "(?=[^a-zа-яё]|$)"
If REci.Test(tmpString) Then IG_ReplaceWholeWord_Array = True Else Exit Function
tmpString = REci.Replace(tmpString, "$1" & aRpl(n))
Next n
Else
For n = LBound(aFind) To UBound(aFind)
RE.Pattern = "(^|[^A-Za-zА-яЁё])" & aFind(n) & "(?=[^A-Za-zА-яЁё]|$)"
If RE.Test(tmpString) Then IG_ReplaceWholeWord_Array = True Else Exit Function
tmpString = RE.Replace(tmpString, "$1" & aRpl(n))
Next n
End If
End Function
'==================================================================================================
'================================================================================================== |
|
Модуль «Splitter»
| Visual Basic | 1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
| Option Base 1
Option Explicit
Option Private Module
'==================================================================================================
Function PRDX_SplitString_ByNonCyrLat(ByVal iStr$, aPart$(), aInd&(), Optional MsgFalse As Boolean) As Boolean
Dim aBt() As Byte
Dim i&, n&, nP&, nI&, bW&, bS&
aBt = iStr
ReDim aPart(Len(iStr))
ReDim aInd(UBound(aPart))
For i = 0 To UBound(aBt) Step 2
n = n + 1
If PRDX_AscW_CyrAndLat_Is(aBt(i) + 256 * aBt(i + 1)) Then ' Ltr
If bW Then GoTo nx Else bW = n
If bS = 0 Then GoTo nx
nP = nP + 1: aPart(nP) = Mid$(iStr, bS, n - bS): bS = 0
Else ' NonLtr
If bS Then GoTo nx Else bS = n
If bW = 0 Then GoTo nx
nP = nP + 1: aPart(nP) = Mid$(iStr, bW, n - bW): bW = 0
nI = nI + 1: aInd(nI) = nP
End If
nx:
Next i
If bW Then
nP = nP + 1: aPart(nP) = Mid$(iStr, bW)
nI = nI + 1: aInd(nI) = nP
Else
If nI = 0 Then If MsgFalse Then MsgBox "There is NO any Cyr/Lat letters in String" & vbLf & iStr, vbCritical, "PRDX_SplitString_ByNonCyrLat": Exit Function Else Exit Function
nP = nP + 1: aPart(nP) = Mid$(iStr, bS)
End If
ReDim Preserve aPart(nP)
ReDim Preserve aInd(nI)
PRDX_SplitString_ByNonCyrLat = nI
End Function
'--------------------------------------------------------------------------------------------------
Private Sub Test_PRDX_SplitString_ByNonCyrLat()
Dim aP$(), aI&()
Dim x, n&, i&
x = "./.asd.gh./*красота/*b./7jg"
'x = ",/"
If PRDX_SplitString_ByNonCyrLat(x, aP, aI, True) Then i = 1 Else Exit Sub
For n = 1 To UBound(aP)
Debug.Print n, "«" & aP(n) & "»",
If aI(i) = n Then Debug.Print 1: i = i + 1 Else Debug.Print 0
Next n
Debug.Print Join(aP, "") = x
End Sub
'==================================================================================================
'==================================================================================================
' Fill aWrd(N) and aSep(N+1)
Function PRDX_SplitString_ByNonCyrLat_Old(ByVal iStr$, aWrd$(), aSep$()) As Boolean
Dim aBt() As Byte
Dim i&, n&, nW&, nS&, bW&, bS&
aBt = iStr
ReDim aWrd(Len(iStr))
ReDim aSep(UBound(aWrd))
For i = 0 To UBound(aBt) Step 2
n = n + 1
If PRDX_AscW_CyrAndLat_Is(aBt(i) + 256 * aBt(i + 1)) Then ' Ltr
If bW Then GoTo nx Else bW = n
If bS = 0 Then
If nS = 0 Then nS = nS + 1: aSep(nS) = ""
GoTo nx
End If
nS = nS + 1: aSep(nS) = Mid$(iStr, bS, n - bS): bS = 0
Else ' NonLtr
If bS Then GoTo nx Else bS = n
If bW = 0 Then GoTo nx
nW = nW + 1: aWrd(nW) = Mid$(iStr, bW, n - bW): bW = 0
End If
nx:
Next i
If bW Then
nW = nW + 1: aWrd(nW) = Mid$(iStr, bW)
Else
nS = nS + 1: aSep(nS) = Mid$(iStr, bS)
End If
If nW = 0 Then Stop: End
If nS < nW Then Stop: End
If nS > nW + 1 Then Stop: End
If nS = nW Then nS = nS + 1: aSep(nS) = ""
ReDim Preserve aWrd(nW)
ReDim Preserve aSep(nS)
PRDX_SplitString_ByNonCyrLat_Old = True
End Function
'--------------------------------------------------------------------------------------------------
Private Sub Test_PRDX_SplitString_ByNonCyrLat_Old()
Dim x, w$(), s$(), n&
x = ",./asd.gh./*красота/*b./7jg,,./"
If Not PRDX_SplitString_ByNonCyrLat_Old(x, w, s) Then Exit Sub
For n = 1 To UBound(s)
Debug.Print "«" & s(n) & "»"
If n < UBound(s) Then Debug.Print "«" & w(n) & "»"
Next n
Debug.Print x = PRDX_SplitString_ByNonCyrLat_Join(w, s, Len(x))
End Sub
'==================================================================================================
Function PRDX_SplitString_ByNonCyrLat_Join(aWrd$(), aSep$(), iLen&) As String
Dim tx$, n&, p&, l&
tx = String$(iLen, " "): p = 1
l = Len(aSep(1))
If l Then Mid$(tx, p, l) = aSep(1): p = p + l
l = Len(aWrd(1)): Mid$(tx, p, l) = aWrd(1): p = p + l
For n = 2 To UBound(aWrd)
l = Len(aSep(n)): Mid$(tx, p, l) = aSep(n): p = p + l
l = Len(aWrd(n)): Mid$(tx, p, l) = aWrd(n): p = p + l
Next n
l = Len(aSep(n))
If l Then Mid$(tx, p, l) = aSep(n)
PRDX_SplitString_ByNonCyrLat_Join = tx
End Function
'==================================================================================================
'==================================================================================================
'==================================================================================================
Private Sub SpeedTest()
Dim tx$, res$, t!, n&, l&, f As Boolean
Dim aP$(), aI&()
Dim aWrd$(), aSep$()
Const nCyc& = 1000000
tx = "Вася вас не Вас,Петя:пет;не,Пет,Alexey-alex*not«Alex»"
l = Len(tx)
t = Timer
For n = 1 To nCyc / 10
' f = PRDX_SplitString_ByNonCyrLat_Old(tx, aWrd, aSep) ' 1.44
' f = PRDX_SplitString_ByNonCyrLat(tx, aP, aI) ' 1.41
Next n
Debug.Print Format$(Timer - t, "0.00"), "Split", f
t = Timer
For n = 1 To nCyc
' res = PRDX_SplitString_ByNonCyrLat_Join(aWrd, aSep, l) ' 1.06
' res = Join(aP, "") ' 0.38
Next n
Debug.Print Format$(Timer - t, "0.00"), "Join", res = tx
End Sub
'================================================================================================== |
|
|
