Как я могу заставить этот макрос работать только на выделенном тексте? И можно ли заставить его работать быстрее?

Question

Мне нужно проверить определенные документы, чтобы определить, является ли количество вставок <или> = 50% от исходного текста. Макрос, который я собрал вместе из различных онлайн-источников, делает это довольно хорошо и выдает одно из двух сообщений в виде окна сообщения в зависимости от рассматриваемого текста.

Однако есть две проблемы:

1. макрос запускается по всему тексту, и я хотел бы, чтобы он запускался только над текстом, который пользователь выбирает вручную перед запуском макрос.
2. на некоторых файлах он зависает долго и иногда вылетает мой P C.

Как настроить макрос так, чтобы он работал только на выделенный текст? И можно ли настроить его так, чтобы он работал быстрее / был более надежным / не подходил sh my P C?

Sub RevMacro2()
  Dim lInsertsWords As Long
  Dim oRevision As Revision

    lInsertsWords = 0
    For Each oRevision In ActiveDocument.Revisions
        Select Case oRevision.Type
            Case wdRevisionInsert
                lInsertsWords = lInsertsWords + oRevision.Range.Words.Count
        End Select
    Next oRevision

n = ActiveDocument.Range.ComputeStatistics(wdStatisticWords)
o = lInsertsWords
p = n / 2

Dim message As String
 If o < p Then
    message = "Blocks:" & vbTab & "60% Copy fee" & vbCr & _
    "Other:" & vbTab & "75% Copy fee"
 End If
 If o >= p Then
    message = "Blocks: 75% Copy fee" & vbCr & _
    "Other: 100% Copy fee" & vbCr
 End If
 MsgBox message

End Sub

Answer 1

Для дополнительного критерия вы можете использовать что-то вроде:

Sub RevMacro()
Dim i As Long, j As Long, n As Long, r As Long
With Selection.Range
  n = .ComputeStatistics(wdStatisticWords): r = .Revisions.Count
  For i = 1 To r
    With .Revisions(i)
      If .Type = wdRevisionInsert Then j = j + .Range.ComputeStatistics(wdStatisticWords)
    End With
  Next
End With
If j / n < 0.5 Then 'less than 50%
  MsgBox "Blocks:" & vbTab & "60% Copy fee" & vbCr & _
  "Other:" & vbTab & "75% Copy fee"
ElseIf j / n < 0.75 Then  '50%+ but less than 75%
  MsgBox "Blocks: 75% Copy fee" & vbCr & _
    "Other: 90% Copy fee" & vbCr
Else '75%+
  MsgBox "Blocks: 90% Copy fee" & vbCr & _
    "Other: 100% Copy fee" & vbCr
End If
End Sub

Answer 2

Попробуйте:

Sub RevMacro()
Dim i As Long, j As Long, n As Long, r As Long
With Selection.Range
  n = .ComputeStatistics(wdStatisticWords) / 2: r = .Revisions.Count
  For i = 1 To r
    With .Revisions(i)
      If .Type = wdRevisionInsert Then j = j + .Range.ComputeStatistics(wdStatisticWords)
    End With
  Next
End With
If j < n Then
  MsgBox "Blocks:" & vbTab & "60% Copy fee" & vbCr & _
    "Other:" & vbTab & "75% Copy fee"
Else
  MsgBox "Blocks: 75% Copy fee" & vbCr & _
    "Other: 100% Copy fee" & vbCr
End If
End Sub