Untitled

Sub HighlightAndCountFillerWords()
    Dim FillerWords As Variant
    Dim WordCount As Object
    Dim i As Integer
    Dim WordToFind As String
    Dim ColorIndex As Long
    Dim WordDict As Object
    Dim FoundCount As Integer
    Dim Msg As String
    Dim Word As String
    Dim AllWords() As String
    Dim TotalWords As Object
    Dim CurrentWord As String
    
    ' Define the list of filler words
    FillerWords = Array("like", "um", "uh", "basically", "actually", "you know", "sort of", "kind of", "literally")
    
    ' Initialize dictionary for filler words count
    Set WordDict = CreateObject("Scripting.Dictionary")
    
    ' Initialize dictionary for all words count
    Set TotalWords = CreateObject("Scripting.Dictionary")
    
    ' Loop through the list of filler words
    For i = LBound(FillerWords) To UBound(FillerWords)
        WordToFind = FillerWords(i)
        
        ' Set different colors based on the index
        Select Case i
            Case 0: ColorIndex = wdYellow
            Case 1: ColorIndex = wdTurquoise
            Case 2: ColorIndex = wdPink
            Case 3: ColorIndex = wdBrightGreen
            Case 4: ColorIndex = wdGray25
            Case 5: ColorIndex = wdBlue
            Case 6: ColorIndex = wdRed
            Case 7: ColorIndex = wdTeal
            Case 8: ColorIndex = wdViolet
        End Select
        
        ' Count and highlight the filler word
        FoundCount = 0
        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
                FoundCount = FoundCount + 1
            Loop
        End With
        
        ' Store the count of each filler word
        If FoundCount > 0 Then
            WordDict(WordToFind) = FoundCount
        End If
    Next i
    
    ' Count all words in the document
    AllWords = Split(ActiveDocument.Content.Text, " ")
    For i = LBound(AllWords) To UBound(AllWords)
        CurrentWord = Trim(LCase(AllWords(i)))
        ' Remove punctuation from the word
        CurrentWord = Replace(CurrentWord, ".", "")
        CurrentWord = Replace(CurrentWord, ",", "")
        CurrentWord = Replace(CurrentWord, ";", "")
        CurrentWord = Replace(CurrentWord, ":", "")
        CurrentWord = Replace(CurrentWord, "?", "")
        CurrentWord = Replace(CurrentWord, "!", "")
        
        ' Count the occurrences of each word
        If Len(CurrentWord) > 0 Then
            If TotalWords.Exists(CurrentWord) Then
                TotalWords(CurrentWord) = TotalWords(CurrentWord) + 1
            Else
                TotalWords.Add CurrentWord, 1
            End If
        End If
    Next i
    
    ' Build the result message for filler words
    Msg = "Filler Words Count:" & vbCrLf
    For Each Word In WordDict.Keys
        Msg = Msg & Word & ": " & WordDict(Word) & vbCrLf
    Next Word
    
    ' Build the result message for most common words
    Msg = Msg & vbCrLf & "Most Common Words:" & vbCrLf
    Dim MostCommonWords As Variant
    MostCommonWords = SortDictionaryByValue(TotalWords)
    
    For i = LBound(MostCommonWords) To UBound(MostCommonWords)
        If i > 9 Then Exit For ' Show top 10 most common words
        Msg = Msg & MostCommonWords(i)(0) & ": " & MostCommonWords(i)(1) & vbCrLf
    Next i
    
    ' Show the result message
    MsgBox Msg
End Sub

' Function to sort dictionary by value and return as array
Function SortDictionaryByValue(dict As Object) As Variant
    Dim key As Variant
    Dim tempArr() As Variant
    Dim i As Long
    Dim j As Long
    Dim tempVal As Variant
    
    ' Convert dictionary to an array of key-value pairs
    ReDim tempArr(0 To dict.Count - 1, 0 To 1)
    i = 0
    For Each key In dict.Keys
        tempArr(i, 0) = key
        tempArr(i, 1) = dict(key)
        i = i + 1
    Next key
    
    ' Sort the array by value (descending)
    For i = LBound(tempArr, 1) To UBound(tempArr, 1) - 1
        For j = i + 1 To UBound(tempArr, 1)
            If tempArr(i, 1) < tempArr(j, 1) Then
                tempVal = tempArr(i, 0)
                tempArr(i, 0) = tempArr(j, 0)
                tempArr(j, 0) = tempVal
                
                tempVal = tempArr(i, 1)
                tempArr(i, 1) = tempArr(j, 1)
                tempArr(j, 1) = tempVal
            End If
        Next j
    Next i
    
    SortDictionaryByValue = tempArr
End Function