VBA: Slow macro looping through paragraphs

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

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

Answer 2

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