Untitled

Sub HighlightAndCountFillerWordsWithSummary()
    Dim FillerWords As Variant
    Dim FillerColors As Variant
    Dim i As Integer
    Dim WordToFind As String
    Dim ColorIndex As Long
    Dim FoundCount As Integer
    Dim WordDict As Object
    Dim Msg As String
    Dim key As Variant
    Dim Rng As Range
    
    ' Define the list of filler words and corresponding highlight colors
    FillerWords = Array("That", "Then", "Just", "Still", "Felt", "Really", "Very", "Feeling")
    FillerColors = Array(14, 10, 14, 6, 7, 5, 9, 16) ' Using color index values
    
    ' Initialize dictionary for filler word count
    Set WordDict = CreateObject("Scripting.Dictionary")
    
    ' Loop through the list of filler words
    For i = LBound(FillerWords) To UBound(FillerWords)
        WordToFind = FillerWords(i)
        ColorIndex = FillerColors(i)
        
        ' Initialize the count
        FoundCount = 0
        
        ' Search for the word and highlight it
        With ActiveDocument.Content.Find
            .Text = WordToFind
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = True
            .MatchCase = False
            .MatchWholeWord = True
            .Replacement.Highlight = True
            .Replacement.HighlightColorIndex = ColorIndex
            
            Do While .Execute(Replace:=wdReplaceNone) = True
                ' Count each occurrence
                FoundCount = FoundCount + 1
            Loop
        End With
        
        ' Store the count in the dictionary
        If FoundCount > 0 Then
            WordDict.Add WordToFind, FoundCount
        End If
    Next i
    
    ' Build the result summary message
    Msg = "Filler Words Count:" & vbCrLf
    For Each key In WordDict.Keys
        Msg = Msg & key & ": " & WordDict(key) & vbCrLf
    Next key
    
    ' Insert the summary at the end of the document
    Set Rng = ActiveDocument.Content
    Rng.Collapse Direction:=wdCollapseEnd
    Rng.InsertParagraphAfter
    Rng.InsertAfter "=== Filler Words Summary ===" & vbCrLf & Msg
    Rng.Style = wdStyleHeading2 ' Formatting for the inserted summary
End Sub