VBA: Slow macro looping through paragraphs - vba

Question

My macro in VBA Word 2016 (Win10) is verys slow for a 3-page document. What can I do to make it faster? Or is there another way I may count characters in paragraphs of different styles? I need to know how many characters are written in Normal style, H1-style etc.
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

Try loading it into memory first, then taking action after the data has been loaded to an array. I just did a test with about 60 pages, it is taking about 8 seconds to populate the various attributes to an array. Once it's in the array, then manipulate it from there.
Here's the code:
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

I'm not sure if this is the proper way of doing this, but at least it works! I hope this code may help someone else looking for a way to loop through paragraphs and count the characters. Thank you Ryan!
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