Возможна ли оптимизация скрипта?

[Vadim39]

Задача: нужно подсчитать количество знаков с цветовым атрибутом 0, стоящих после фигурной скобки.
Сделал так:

Sub test3()
Dim rng As Range
Set rng = ActiveDocument.Range
    With rng.Find
           .Text = "{^?"
           .Forward = True
           .Wrap = wdFindAsk
           .Format = False
           .MatchCase = True
           .MatchWholeWord = False
           .MatchKashida = False
           .MatchDiacritics = False
           .MatchAlefHamza = False
           .MatchControl = False
           .MatchWildcards = False
           .MatchSoundsLike = False
           .MatchAllWordForms = False
    End With
    Do While rng.Find.Execute = True
        rng.Start = rng.Start + 1
        If rng.Font.ColorIndex = 0 Then k = k + 1
    Loop
    
    Debug.Print k
End Sub

Работает, но довольно медленно. Возможно ли ускорить?
ЗарСпасБОл!

[shanemac51]

как вариант

Sub test3a()
''Задача: нужно подсчитать количество знаков с цветовым атрибутом 0,
'' стоящих после фигурной скобки.
''Сделал так:
''Код:
''Работает, но довольно медленно. Возможно ли ускорить?

Dim rng As Range
Dim k
k = 0
Set rng = ActiveDocument.Range
    With rng.Find
           .Text = "{^?"
           '.Forward = True
           .Wrap = wdFindAsk
           .Format = False
           .MatchCase = True
           .MatchWholeWord = False
           .MatchKashida = False
           .MatchDiacritics = False
           .MatchAlefHamza = False
           .MatchControl = False
           .MatchWildcards = False
           .MatchSoundsLike = False
           .MatchAllWordForms = False
    End With
Dim j1
j1 = 0
Do While rng.Find.Execute = True
j1 = j1 + 1
rng.Start = rng.Start + 1
rng.End = rng.End + 5
'''''''''''''''''''''''''''''''''''''
If rng.Font.ColorIndex > -6 Then
'>-6 все
'=0  avto
'=6  красный
'''''''''''''''''''''''''''''''''''''
k = k + 1
Debug.Print
Debug.Print "k="; k; j1; rng.Start; rng.Font.ColorIndex; rng.Text; "="
';Debug.Print rng.Text
''k = k + 0
End If
Loop
Debug.Print k
MsgBox "найдено скобок= " & k
End Sub

Private Sub CommandButton1_Click()
Call test3a
End Sub

[Vadim39]

shanemac51 Спасибо, но скорость та же.
Однако, похоже способ найден. (Основное время занимал повтор процедуры rng.Find.Execute)

Sub test3b()
Dim rng As Range
tm = Timer
Set rng = ActiveDocument.Range
allTx = rng.Text
ln = Len(allTx)
For i = 1 To ln
    If Mid(allTx, i, 1) = "{" Then
'неверно       rng.Start = i + 1 
'неверно        rng.End = i + 1
        rng.Start = i 
        rng.End = i
        vsSkobok = vsSkobok + 1
        If rng.Font.ColorIndex = 0 Then k = k + 1
    End If
Next i
Debug.Print
Debug.Print k; " из "; vsSkobok
Debug.Print "Заняло "; Timer - tm; " сек."
End Sub

[shanemac51]

проверила test3b --непонятно считает
---------

Sub test3b26()
Dim rng As Range
Dim alltx, tm, ln, i, k, vsSkobok
tm = Timer
Set rng = ActiveDocument.Range
alltx = rng.Text
ln = Len(alltx)
k = 0
vsSkobok = 0
For i = 1 To ln
If Mid(alltx, i, 1) = "{" Then
rng.Start = i + 1
rng.End = i + 1
vsSkobok = vsSkobok + 1
If rng.Font.ColorIndex = 0 Then
k = k + 1
Debug.Print i, rng.Start, rng.End, Mid(alltx, i, 10)
k = k + 0        ''для останова
End If
End If
Next i
Debug.Print "len alltx=", ln
Debug.Print k; " из "; vsSkobok
Debug.Print "Заняло "; (Timer - tm) * 1000; " mсек."
''{ПРИКАЗ}
''{Министерс
''{Волгоград
''{ПРИКАЗ}
''
''len alltx=     1006
''4   из 6
''Заняло  31.00586  mсек.
''------------убрала поля-получила дркгой выбор,но тоже неправильный
''  42            43            43          {Волгоград
'' 287           288           288          {ПРИКАЗ}
''
'' 542           543           543          {Волгоград
'' 787           788           788          {ПРИКАЗ}
''-------------долдно быть -------я удвоила докуmент( сначалп сделала 50 копий
''и получила к=более 100,хотя дб к=50
''для разбора уменьшила до 2 копий
End Sub
Sub test3b27()
Dim rng As Range
Dim alltx, tm, ln, jk, i, k, vsSkobok
Dim pr As Paragraph
Dim c1
';As Characters
tm = Timer
k = 0
vsSkobok = 0
ln = 0
For Each pr In Word.ActiveDocument.Paragraphs
alltx = pr.Range.Text

jk = InStr(alltx, "{")
ln = ln + Len(alltx)
If jk > 0 Then
'ln = Len(alltx) - 1
Do While jk > 0
'    If Mid(alltx, jk, 1) = "{" Then
c1 = pr.Range.Characters(jk + 1).Font.ColorIndex
'Debug.Print pr.Range.Characters(jk + 1).Text;
vsSkobok = vsSkobok + 1
If c1 = 0 Then
pr.Range.Select
Debug.Print pr.Range.Text
k = k + 1

End If
'    End If
alltx = Mid(alltx, jk + 1)
jk = InStr(alltx, "{")

Loop
End If
Next pr
Debug.Print Now
Debug.Print "len alltx=", ln
Debug.Print k; " из "; vsSkobok
Debug.Print "Заняло "; (Timer - tm) * 1000; " mсек."
''{Волгоградской области}
''{Волгоградской области}
''
''len alltx=     1006
''2   из 6
''Заняло  15.13672  mсек.
End Sub

[Vadim39]

Не совсем понятно, что вы имеете в виду, но вы правы. В скрипте ошибка: вместо

rng.Start = i + 1
rng.End = i + 1

должно быть

rng.Start = i
rng.End = i

Совсем забыл, что позиции диапазона начинаются с нуля, а строки - с единицы
Исправил в предыдущем посте