Добрый день. Имеется шаблон, чтобы вытащить слова, у которых 1-я буква прописная, а остальные строчные. Так, код:
Код
Sub пример()
Set objRegExp = CreateObject("VBScript.RegExp")
objRegExp.Pattern = "\b[A-ZА-ЯЁ][a-zа-яё]+\b"
objRegExp.Global = True
Set objMatches = objRegExp.Execute(ActiveCell.Value)
For i = 0 To objMatches.Count - 1
ActiveCell.Offset(, i + 1).Value = objMatches.Item(i).Value
Next
End Sub
действует на текст: "Perviy 1-y Vtoroy 2-y" (вытаскивает "Perviy" и "Vtoroy") но не действует на текст: "Первый 1-й Второй 2-й" (ничего не вытаскивает)
Проверил корректно ли написаны в шаблоне буквы а и А (и латинскими и кириллицей) --> не помогло.
Option Explicit
Option Private Module
'====================================================================================================
Sub Test()
Dim arr(), t!, n&
t = Timer
For n = 1 To 1000000
arr = GetProper("Первый первый 1-й Vtoroy vtoroy 2-y")
Next n
Debug.Print Timer - t
[a1].Resize(1, UBound(arr)).Value = arr
End Sub
'====================================================================================================
Function GetProper(v) As Variant()
Dim x, spl(), n&
ReDim spl(1 To 100)
For Each x In Split(v)
If x Like "[A-ZЁА-Я]*" Then n = n + 1: spl(n) = x
Next x
If n Then ReDim Preserve spl(1 To n): GetProper = spl
End Function
'====================================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
vikttur, ну я обычно так и делаю, но тут ведь пример всё-таки, а там дополнительная переменная Добавлю вариант
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Option Explicit
Option Private Module
'====================================================================================================
Sub Test()
Dim x, arr(), tx$, t!, n&, e&
tx = "Первый первый 1-й Vtoroy vtoroy 2-y"
t = Timer
For n = 1 To 1000000
' arr = GetProper(tx) ' 3.45
' x = tx: e = GetProperSlow(x) ' 5.2
' arr = GetProperRP(tx) ' 3.7
x = GetProperRP2(tx) ' 2.1
Next n
Debug.Print Timer - t
'[a1].Resize(1, arr(0)).Value = arr(1) ' GetProper
'[a1].Resize(1, e).Value = x ' Slow
'[a1].Resize(1, UBound(arr)).Value = arr ' RP
[a1].Resize(1, UBound(x) + 1).Value = x ' RP2
End Sub
'====================================================================================================
'====================================================================================================
Function GetProperRP(v) As Variant()
Dim x, spl(), n&
ReDim spl(1 To 100)
For Each x In Split(v)
If x Like "[A-ZЁА-Я]*" Then n = n + 1: spl(n) = x
Next x
If n Then ReDim Preserve spl(1 To n): GetProperRP = spl
End Function
'----------------------------------------------------------------------------------------------------
Function GetProperRP2(v) As Variant
Dim x, spl, n&
spl = Split(v): n = -1
For Each x In spl
If x Like "[A-ZЁА-Я]*" Then n = n + 1: spl(n) = x
Next x
If n <> -1 Then ReDim Preserve spl(n): GetProperRP2 = spl
End Function
'----------------------------------------------------------------------------------------------------
Function GetProper(v) As Variant()
Dim x, aRes(1), spl, n&
spl = Split(v): n = -1
For Each x In spl
If x Like "[A-ZЁА-Я]*" Then n = n + 1: spl(n) = x
Next x
If n = -1 Then Exit Function
aRes(0) = n + 1: aRes(1) = spl: GetProper = aRes
End Function
'----------------------------------------------------------------------------------------------------
Function GetProperSlow(v) As Long
Dim x, spl(), n&
ReDim spl(1 To 100)
For Each x In Split(v)
If x Like "[A-ZЁА-Я]*" Then n = n + 1: spl(n) = x
Next x
If n = 0 Then Exit Function
v = spl: GetProperSlow = n
End Function
'====================================================================================================
можно ещё ускорить, но придётся передавать в функцию массив для заполнения и переменную счётчика или, того хуже, делать глобальные переменные уровня модуля
Ни хрена я заметно не выиграл)))
Код
Option Explicit
Option Private Module
'====================================================================================================
Sub Test()
Dim x, arr() As String, tx$, t!, n&, e&, f As Boolean
tx = "Первый первый 1-й Vtoroy vtoroy 2-y"
t = Timer
For n = 1 To 1000000
' x = GetProperRP2(tx) ' 2.1
f = GetProperFast(tx, arr, e) ' 2
Next n
Debug.Print Timer - t
'[a1].Resize(1, UBound(x) + 1).Value = x ' RP2
[a1].Resize(1, e).Value = arr ' Fast
End Sub
'====================================================================================================
'====================================================================================================
Function GetProperRP2(v) As Variant
Dim x, spl, n&
spl = Split(v): n = -1
For Each x In spl
If x Like "[A-ZЁА-Я]*" Then n = n + 1: spl(n) = x
Next x
If n <> -1 Then ReDim Preserve spl(n): GetProperRP2 = spl
End Function
'----------------------------------------------------------------------------------------------------
Function GetProperFast(v, arr() As String, e&) As Boolean
Dim x
arr = Split(v): e = -1
For Each x In arr
If x Like "[A-ZЁА-Я]*" Then e = e + 1: arr(e) = x
Next x
End Function
'====================================================================================================
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄