Sub StartHere()
    Dim osld As Slide
    Dim oshp As Shape
    Dim rayTitles() As String
    Dim i As Integer
    ReDim rayTitles(1 To 1)
    For Each osld In ActivePresentation.Slides
        For Each oshp In osld.Shapes
            If oshp.HasTextFrame Then
                If oshp.TextFrame.HasText Then
                    For i = 1 To oshp.TextFrame.TextRange.Runs.Count
                        With oshp.TextFrame.TextRange.Runs(i).Font
                            If .Color.RGB = vbRed And .Bold = True Then
                                rayTitles(UBound(rayTitles)) = oshp.TextFrame.TextRange.Runs(i) & "\" & osld.SlideNumber
                                ReDim Preserve rayTitles(1 To UBound(rayTitles) + 1)
                            End If
                        End With
                    Next i
                End If
            End If
        Next oshp
    Next osld
    ReDim Preserve rayTitles(1 To UBound(rayTitles) - 1)
    Call mySort(rayTitles)
    Call make_sum(rayTitles)
End Sub
Function mySort(ArrayIn As Variant) As Variant
    Dim b_Cont As Boolean
    Dim lngCount As Long
    Dim strSwap As String
    Do
        b_Cont = False
        For lngCount = LBound(ArrayIn) To UBound(ArrayIn) - 1
            'If ArrayIn(lngCount) > ArrayIn(lngCount + 1) Then
            If LCase(ArrayIn(lngCount)) > LCase(ArrayIn(lngCount + 1)) Then
                strSwap = ArrayIn(lngCount)
                ArrayIn(lngCount) = ArrayIn(lngCount + 1)
                ArrayIn(lngCount + 1) = strSwap
                b_Cont = True
            End If
        Next lngCount
    Loop Until Not b_Cont
End Function
Sub make_sum(rayInstring As Variant)
    Dim osld As Slide
    Dim i As Integer
    For Each osld In ActivePresentation.Slides
        If osld.Tags("SUM") = "YES" Then
            osld.Delete
            Exit For
        End If
    Next osld
    Set osld = ActivePresentation.Slides.Add(1, ppLayoutText)
    osld.Tags.Add "SUM", "YES"
    osld.Shapes(2).TextFrame2.AutoSize = msoAutoSizeTextToFitShape
    osld.Shapes(2).TextFrame.Ruler.TabStops.Add ppTabStopLeft, 450
    With osld
        For i = 1 To UBound(rayInstring)
            .Shapes(2).TextFrame.TextRange = .Shapes(2).TextFrame.TextRange & Split(rayInstring(i), "\")(0) & " (" & Split(rayInstring(i), "\")(1) & ")" & vbCrLf & vbCrLf
        Next i
    End With
    MsgBox "Done", vbInformation, "Done!"
End Sub

Sub InsertingIndexEntries()
    Application.ScreenUpdating = False

    'Go to the first page of the document
    Selection.HomeKey wdStory, wdMove

    'Set up the Find and Replace operation
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchWildcards = False
        .Font.Bold = True
        .Font.ColorIndex = wdRed ' I added this so it looks for red text
    End With

    'Finds the bold text and inserts an index entry.
    Do
        Selection.Find.Execute
        If Selection.Find.Found Then
            'Checks if the Index field was selected
            'This occurs if it does not contain any entries
            If UCase(Selection.Range.Text) <> "NO INDEX ENTRIES FOUND." Then
                'Insert an index entry and use the text within
                'the selected range as the entry name
                ActiveDocument.Indexes.MarkEntry _
                  Range:=Selection.Range, _
                  Entry:=Selection.Range.Text, _
                  EntryAutoText:=Selection.Range.Text, _
                  CrossReference:="", _
                  CrossReferenceAutoText:="", _
                  BookmarkName:="", _
                  Bold:=False, _
                  Italic:=False, _
                  Reading:=""
                'Move past text that was found and the new index entry
                Selection.MoveRight wdCharacter, 1, wdExtend
                Selection.Collapse wdCollapseEnd
            End If
        End If
    Loop While Selection.Find.Found

    Application.ScreenUpdating = True
    Application.ScreenRefresh
    MsgBox "Done"
End Sub