VBA: медленный цикл макросов через абзацы

Question

Мой макрос в VBA Word 2016 (Win10) очень медленный для трехстраничного документа. Что я могу сделать, чтобы сделать это быстрее? Или есть другой способ, который я могу считать персонажами в параграфах разных стилей? Мне нужно знать, сколько символов написано в стиле Normal, H1-стиле и т.д.

Sub avsnittsteller() 

'Optimize Code 
Application.ScreenUpdating = False 

'Rydd opp i formateringen 
'Call stilFinner 

intTittel = ActiveDocument.CustomDocumentProperties("malTittel").Value 
intTittelI = ActiveDocument.CustomDocumentProperties("malTittelI").Value 
intTittelX = ActiveDocument.CustomDocumentProperties("malTittelX").Value 
intIngress = ActiveDocument.CustomDocumentProperties("malIngress").Value 
intNormal = ActiveDocument.CustomDocumentProperties("malNormal").Value 

'sett variablene til 0 før de avsnittene telles 
Dim mlm(10) As String 
tittel = 0 
ingress = 0 
mlm(1) = 0 
mlm(2) = 0 
mlm(3) = 0 
mlm(4) = 0 
mlm(5) = 0 
mlm(6) = 0 
mlm(7) = 0 

' TELLE TEGN I ALLE AVSNITT 
Dim Doc As Document 
Set Doc = ActiveDocument 
Dim para As Paragraph 
Dim i As Long: i = 0 
Dim j As Long: j = 0 
Dim k As Long: k = 0 

For Each para In Doc.Paragraphs 
    If para.Style = Doc.Styles("instruksjon") Or _ 
    para.Style = Doc.Styles("Bildetekst") Or _ 
    para.Style = Doc.Styles("Byline") Or _ 
    para.Style = Doc.Styles("Byline email") Or _ 
    para.Style = Doc.Styles("Fakta punkt") Or _ 
    para.Style = Doc.Styles("tittel") Then 
    Else 
    If para.Style = Doc.Styles(wdStyleHeading1) Then 
     tittel = para.Range.Characters.Count - 1 
    Else 
     If para.Style = Doc.Styles(wdStyleHeading2) Then 
      ingress = para.Range.Characters.Count - 1 
     Else 
      If para.Style = Doc.Styles(wdStyleHeading3) Then 
       i = i + 1 
       mlm(i) = para.Range.Characters.Count - 1 
      Else 
       If para.Style = Doc.Styles(wdStyleNormal) Then 
        j = j + para.Range.Characters.Count - 1 
       End If 'N 
      End If 'H3 
     End If 'H2 
    End If 'H1 
    End If 'alle andre stiler 
Next para 
normal = j 
'MsgBox "Tittelen din har " & tittel & " tegn" & vbCrLf & " ingress " & ingress & vbCrLf & " mlm-3 " & mlm(3) & vbCrLf & " mlm-4 " & mlm(4) & vbCrLf & "Alle normal " & normal 
'MsgBox "Dokumentet blir nå lagret og antall tegn du har skrevet blir oppdatert øverst i dokumentet." 
'MsgBox ActiveDocument.Paragraphs.Count 

'DEFINER DOC PROPERTIES VARIABLENE 
ActiveDocument.CustomDocumentProperties("tittel").Value = tittel 
ActiveDocument.CustomDocumentProperties("ingress").Value = ingress 
ActiveDocument.CustomDocumentProperties("mlm1").Value = mlm(1) 
ActiveDocument.CustomDocumentProperties("mlm2").Value = mlm(2) 
ActiveDocument.CustomDocumentProperties("mlm3").Value = mlm(3) 
ActiveDocument.CustomDocumentProperties("mlm4").Value = mlm(4) 
ActiveDocument.CustomDocumentProperties("mlm5").Value = mlm(5) 
ActiveDocument.CustomDocumentProperties("mlm6").Value = mlm(6) 
ActiveDocument.CustomDocumentProperties("mlm7").Value = mlm(7) 
ActiveDocument.CustomDocumentProperties("normal").Value = j 

ActiveDocument.Fields.Update 'OPPDATER ALLE FELT nb, virker ikke i bunn og topptekst 

'MsgBox intTittelX 

'Farg tittel og ingress rød om de er for lange, blå om de er passe korte 
If tittel > intTittelX Then 
    With ActiveDocument.Styles(wdStyleHeading1).Font 
     .Color = wdColorRed 
    End With 
Else 
    With ActiveDocument.Styles(wdStyleHeading1).Font 
     .Color = -738148353 
    End With 
End If 

If ingress > intIngress Then 
    With ActiveDocument.Styles(wdStyleHeading2).Font 
     .Color = wdColorRed 
    End With 
Else 
    With ActiveDocument.Styles(wdStyleHeading2).Font 
     .Color = -738148353 
    End With 
End If 


'Optimize Code 
Application.ScreenUpdating = True 

End Sub 

Answer 1

Попробуйте загрузить его в память, а затем принимать меры после того, как данные были загружены в массив. Я только что проверил около 60 страниц, для заполнения различных атрибутов массиву требуется около 8 секунд. Как только он находится в массиве, тогда манипулируйте им оттуда.

Вот код:

Option Explicit 

Public Sub test() 
    Debug.Print Now() 
    Dim doc  As Document: Set doc = ActiveDocument 
    Dim i  As Long 
    Dim myArr As Variant: ReDim myArr(1, 0 To doc.Paragraphs.Count - 1) 
    Dim para As Paragraph 

    For Each para In doc.Paragraphs 
     myArr(0, i) = para.Style 
     myArr(1, i) = para.Range.Characters.Count 
     i = i + 1 
    Next 

    Debug.Print Now() 
    Debug.Print myArr(0, 0), myArr(1, 0) 

End Sub 

Answer 2

Я не уверен, если это правильный способ сделать это, но, по крайней мере, это работает! Я надеюсь, что этот код может помочь кому-то еще искать способ перебрать абзацы и подсчитать символы. Спасибо, Райан!

  Option Explicit 

      Public Sub avsnittsteller() 
      'http://stackoverflow.com/questions/42390551/vba-slow-macro-looping-through-paragraphs 
      Debug.Print Now() 
      Application.ScreenUpdating = True 

      'Rydd opp i formateringen 
      Call stilFinner 
       'deklarere variablene 
       Dim doc  As Document: Set doc = ActiveDocument 
       Dim i  As Long 
       Dim j  As Long 
       Dim k  As Long 
       Dim H1  As Long 
       Dim H2  As Long 
       Dim H3  As Long 
       Dim N  As Long 
       Dim myArr As Variant: ReDim myArr(1, 0 To doc.Paragraphs.Count - 1) 
       Dim mlm(10) As String 
       Dim para As Paragraph 
       'Hent fram verdier i globale variabler som angir riktig lengde 
       intTittel = ActiveDocument.CustomDocumentProperties("malTittel").Value 
       intTittelI = ActiveDocument.CustomDocumentProperties("malTittelI").Value 
       intTittelX = ActiveDocument.CustomDocumentProperties("malTittelX").Value 
       intIngress = ActiveDocument.CustomDocumentProperties("malIngress").Value 
       intNormal = ActiveDocument.CustomDocumentProperties("malNormal").Value 

       'sett variablene til 0 før de avsnittene telles 
       tittel = 0 
       ingress = 0 
       mlm(1) = 0 
       mlm(2) = 0 
       mlm(3) = 0 
       mlm(4) = 0 
       mlm(5) = 0 
       mlm(6) = 0 
       mlm(7) = 0 

       'Lag en matrise (array) i minnet og kjør søket fra den 
      'Debug.Print doc.Paragraphs.Count 
       For Each para In doc.Paragraphs 
        myArr(0, i) = para.Style 
        myArr(1, i) = para.Range.Characters.Count - 1 'ComputeStatistics(wdStatisticCharacters) 
        i = i + 1 
       Next 
       'For hvert avsnitt fra 0 til antall avsnitt i dokumentet 
        For j = 0 To doc.Paragraphs.Count - 1 
         'Hvis avsnittets stil er Normal eller en av overskriftene så legg sammen alle tegnene 
         If myArr(0, j) = "Normal" Then 
          N = N + myArr(1, j) 
         'Debug.Print j, myArr(0, j), myArr(1, j) 
         End If 
         If myArr(0, j) = "Overskrift 1" Or myArr(0, j) = "Heading 1" Then 
          H1 = H1 + myArr(1, j) 
         'Debug.Print j, myArr(0, j), myArr(1, j) 
         End If 
         If myArr(0, j) = "Overskrift 2" Or myArr(0, j) = "Heading 2" Then 
          H2 = H2 + myArr(1, j) 
         'Debug.Print j, myArr(0, j), myArr(1, j) 
         End If 
         If myArr(0, j) = "Overskrift 3" Or myArr(0, j) = "Heading 3" Then 
          'Alle avsnitt med H3 telles ett og ett, summeres ikke 
          k = k + 1 
          mlm(k) = myArr(1, j) 
         Debug.Print j, myArr(0, j), myArr(1, j) 
         End If 
        Next j 'Neste avsnitt 
      'Debug.Print N & " " & H1 & " " & H2 
      'Debug.Print mlm(1) & " " & mlm(2) & " " & mlm(3) & " " & mlm(4) & " " & mlm(5) 

         'DEFINER DOC PROPERTIES VARIABLENE 
         ActiveDocument.CustomDocumentProperties("tittel").Value = H1 
         ActiveDocument.CustomDocumentProperties("ingress").Value = H2 
         ActiveDocument.CustomDocumentProperties("mlm1").Value = mlm(1) 
         ActiveDocument.CustomDocumentProperties("mlm2").Value = mlm(2) 
         ActiveDocument.CustomDocumentProperties("mlm3").Value = mlm(3) 
         ActiveDocument.CustomDocumentProperties("mlm4").Value = mlm(4) 
         ActiveDocument.CustomDocumentProperties("mlm5").Value = mlm(5) 
         ActiveDocument.CustomDocumentProperties("mlm6").Value = mlm(6) 
         ActiveDocument.CustomDocumentProperties("mlm7").Value = mlm(7) 
         ActiveDocument.CustomDocumentProperties("normal").Value = N 

         ActiveDocument.Fields.Update 'OPPDATER ALLE FELT nb, virker ikke i bunn og topptekst 

         'Farg tittel og ingress rød om de er for lange, blå om de er passe korte 
         If tittel > intTittelX Then 
          With ActiveDocument.Styles(wdStyleHeading1).Font 
           .Color = wdColorRed 
          End With 
         Else 
          With ActiveDocument.Styles(wdStyleHeading1).Font 
           .Color = -738148353 
          End With 
         End If 

         If ingress > intIngress Then 
          With ActiveDocument.Styles(wdStyleHeading2).Font 
           .Color = wdColorRed 
          End With 
         Else 
          With ActiveDocument.Styles(wdStyleHeading2).Font 
           .Color = -738148353 
          End With 
         End If 

      Application.ScreenUpdating = True 
      Debug.Print Now() 
      End Sub