VBA Word Macro to Prepend Text Based on Font Color Match in Word Document

I am trying to create a VBA macro in Microsoft Word that will:

1. Start with a selection of text that serves as a "color key." Each line in the selection has a unique color and text string.

2. Store the font color and text for each line in the selection.

3. Search the rest of the document for paragraphs with font colors that match any color in the "color key" selection.

4. Prepend the matching text from the color key to any paragraphs that share the same font color.

The expected output should be like this, if the three lines were selected and the macro was ran.

Code, i have attempted

Sub ApplyColorKeyPrefixes()

    Dim doc As Document
    Dim selectedRange As Range
    Dim colorKeyColors As Collection
    Dim colorKeyPrefixes As Collection
    Dim para As Paragraph
    Dim line As Range
    Dim colorCode As Long
    Dim prefixText As String
    Dim i As Long

    ' Initialize document and collections for color key
    Set doc = ActiveDocument
    Set colorKeyColors = New Collection
    Set colorKeyPrefixes = New Collection
    Set selectedRange = Selection.Range

    For i = 1 To selectedRange.Paragraphs.Count
        Set line = selectedRange.Paragraphs(i).Range
        line.End = line.End - 1  ' Exclude paragraph mark

        ' Store the color and corresponding text
        colorCode = line.Font.Color
        prefixText = Trim(line.Text)

        On Error Resume Next
        colorKeyColors.Add colorCode, CStr(colorCode)
        colorKeyPrefixes.Add prefixText, CStr(colorCode)
        On Error GoTo 0
    Next i

    'oop through all paragraphs in the document (after selection) to find matches
    For Each para In doc.Paragraphs
        ' Skip paragraphs in the initial selection
        If para.Range.Start >= selectedRange.End Then
            Set line = para.Range.Words(1)  ' use first text of selection to determine color
            colorCode = line.Font.Color
            
            ' Check if color match in parag
            On Error Resume Next
            prefixText = colorKeyPrefixes(CStr(colorCode))
            On Error GoTo 0

            If prefixText <> "" Then
                para.Range.InsertBefore prefixText & ": "
                
                ' Retain color for the og text and the prefix text
                para.Range.Words(1).Font.Color = colorCode
                para.Range.Font.Color = colorCode
            End If
        End If
    Next para

    Set colorKeyColors = Nothing
    Set colorKeyPrefixes = Nothing

End Sub

The Issue The code is currently applying prefixes to all paragraphs, not just the ones with matching font colors. I suspect there may be an issue with how I’m checking for font color matches in colorKeyPrefixes, but I’m not sure where the problem lies.

How can I modify the macro so that it only appends the prefix text to paragraphs that have the same font color as one of the lines in the selected "color key"?

Additional Notes Each line in the selection is guaranteed to have only one color. The color key might contain up to 12 different colors. I'm using the first word of each paragraph to check for the color (assuming that color applies to the entire paragraph).

A far better way to approach this is to break the operation into two procedures, and use Find to get the applicable paragraphs rather than crawling through the paragraphs collection.

Sub ApplyColorKeyPrefixes()

Dim para As Paragraph, keyRange As Range
Dim startFind As Long

startFind = Selection.Range.End + 1

For Each para In Selection.Paragraphs
    Set keyRange = para.Range
    keyRange.MoveEnd wdCharacter, -1
    FindandApplyColorKey startFind, keyRange.Font.Color, keyRange.Text & " "
Next

End Sub

Private Sub FindandApplyColorKey(rngStart As Long, textColor As Long, prefixText As String)
    Dim findRange As Range
    Set findRange = ActiveDocument.Content
    With findRange
        .Start = rngStart
        With .Find
            .ClearFormatting
            .Format = True
            .Forward = True
            .Wrap = wdFindStop
            .Text = ""
            .Font.Color = textColor
        End With
        Do While .Find.Execute
            .InsertBefore prefixText
        Loop
    End With
End Sub