Word VBA: iterating through characters is incredibly slow

Question

I have a macro that changes single quotes before a number to an apostrophe (or closes a single curly quote). Usually, when you enter the word “80s” into a word, the apostrophe before “8” refers to the wrong path. The macro below works, but it is incredibly slow (e.g. 10 seconds per page). In a regular language (even interpreted) this will be a quick procedure. Any ideas on why this takes so long in VBA on Word 2007? Or, if someone has a find + replacement skills that can do this without iteration, please let me know.

Sub FixNumericalReverseQuotes()
    Dim char As Range
    Debug.Print "starting " + CStr(Now)
    With Selection
        total = .Characters.Count
        ' Will be looking ahead one character, so we need at least 2 in the selection
        If total < 2 Then
            Return
        End If
        For x = 1 To total - 1
            a_code = Asc(.Characters(x))
            b_code = Asc(.Characters(x + 1))

            ' We want to convert a single quote in front of a number to an apostrophe
            ' Trying to use all numerical comparisons to speed this up
            If (a_code = 145 Or a_code = 39) And b_code >= 48 And b_code <= 57 Then
                .Characters(x) = Chr(146)
            End If 
        Next x
    End With
    Debug.Print "ending " + CStr(Now)
End Sub

Answer 1

(...? ??) - Word. - obj.Next, . :

For i = 1 to ActiveDocument.Characters.Count
    'Do something with ActiveDocument.Characters(i), e.g.:
    Debug.Pring ActiveDocument.Characters(i).Text
Next

:

Dim ch as Range: Set ch = ActiveDocument.Characters(1)
Do
    'Do something with ch, e.g.:
    Debug.Print ch.Text
    Set ch = ch.Next 'Note iterating
Loop Until ch is Nothing

: 00:03:30 00:00:06, 3 6 .

Google, , . .

Answer 2

, . . , , , .

- :

Public Sub FixNumericalReverseQuotesFast()

    Dim expression As RegExp
    Set expression = New RegExp

    Dim buffer As String
    buffer = Selection.Range.Text

    expression.Global = True
    expression.MultiLine = True
    expression.Pattern = "[" & Chr$(145) & Chr$(39) & "]\d"

    Dim matches As MatchCollection
    Set matches = expression.Execute(buffer)

    Dim found As Match
    For Each found In matches
        buffer = Replace(buffer, found, Chr$(146) & Right$(found, 1))
    Next

    Selection.Range.Text = buffer

End Sub

. Microsoft VBScript Regular Expressions 5.5 ( ).

EDIT: - . :

Sub FixNumericalReverseQuotes()
    Dim chars() As Byte
    chars = StrConv(Selection.Text, vbFromUnicode)

    Dim pos As Long
    For pos = 0 To UBound(chars) - 1
        If (chars(pos) = 145 Or chars(pos) = 39) _
        And (chars(pos + 1) >= 48 And chars(pos + 1) <= 57) Then
           chars(pos) = 146
        End If
    Next pos

    Selection.Text = StrConv(chars, vbUnicode)
End Sub

(100 , 3 100 "" ):

• Regex: 1.4375
• : 2,765625
• OP: ( 23 )

, Regex, 10 .

2: -, , 3:

Sub FixNumericalReverseQuotesVThree()

    Dim full_text As Range
    Dim cached As Long

    Set full_text = ActiveDocument.Range
    full_text.Find.ClearFormatting
    full_text.Find.MatchWildcards = True
    cached = full_text.End

    Do While full_text.Find.Execute("[" & Chr$(145) & Chr$(39) & "][0-9]")
        full_text.End = full_text.Start + 2
        full_text.Characters(1) = Chr$(96)
        full_text.Start = full_text.Start + 1
        full_text.End = cached
    Loop

End Sub

, , , ( ms).

Answer 3

@Comintern " ":

Sub FixNumericalReverseQuotes()
    Dim chars() As Byte
    chars = StrConv(Selection.Text, vbFromUnicode)

    Dim pos As Long
    For pos = 0 To UBound(chars) - 1
        If (chars(pos) = 145 Or chars(pos) = 39) _
        And (chars(pos + 1) >= 48 And chars(pos + 1) <= 57) Then
           ' Make the change directly in the selection so track changes is sensible.
           ' I have to use 213 instead of 146 for reasons I don't understand--
           ' probably has to do with encoding on Mac, but anyway, this shows the change.
           Selection.Characters(pos + 1) = Chr(213)
        End If
    Next pos
End Sub

Answer 4

, ?

Sub FixNumQuotes()
    Dim MyArr As Variant, MyString As String, X As Long, Z As Long
    Debug.Print "starting " + CStr(Now)
    For Z = 145 To 146
        MyArr = Split(Selection.Text, Chr(Z))
        For X = LBound(MyArr) To UBound(MyArr)
            If IsNumeric(Left(MyArr(X), 1)) Then MyArr(X) = "'" & MyArr(X)
        Next
        MyString = Join(MyArr, Chr(Z))
        Selection.Text = MyString
    Next
    Selection.Text = Replace(Replace(Selection.Text, Chr(146) & "'", "'"), Chr(145) & "'", "'")
    Debug.Print "ending " + CStr(Now)
End Sub

100% , , , , .

chr (145), char , .

chr (145), chr (146). , ( -, ) , . .

- , , - , .

Answer 5

. , document.text. , document.range(, ), . .

, . , - ( ). , document.text BEL, . , , , , .text.

, document.text, " " . , , /. Document.text , / . .

, (, ) - :

Set matchRange = doc.Range.Characters(myMatches(j).FirstIndex + 1)           
matchRange.Collapse (wdCollapseStart)
Call matchRange.MoveEnd(WdUnits.wdCharacter, myMatches(j).Length)
matchRange.text = Replacement

, , - , Word , . , , , .

In the bottom line, I could not find a suitable way to match the indexing of the document.text line with the equivalent range (start, end), which is not a performance error.

Ideas are welcome, and thanks.