Excel - cómo colorear solo palabras duplicadas con otra celda y no toda la celda

Sub Macro1()

    ActiveCell.FormulaR1C1 = "Si 1 palabra no aparece no se le cambia el color"

    With ActiveCell.Characters(Start:=1, Length:=0).Font

        .Name = "Calibri"

        .FontStyle = "Normal"

        .Size = 11

        .Strikethrough = False

        .Superscript = False

        .Subscript = False

        .OutlineFont = False

        .Shadow = False

        .Underline = xlUnderlineStyleNone

        .ThemeColor = xlThemeColorLight1

        .TintAndShade = 0

        .ThemeFont = xlThemeFontMinor

    End With

    With ActiveCell.Characters(Start:=1, Length:=2).Font

        .Name = "Calibri"

        .FontStyle = "Normal"

        .Size = 11

        .Strikethrough = False

        .Superscript = False

        .Subscript = False

        .OutlineFont = False

        .Shadow = False

        .Underline = xlUnderlineStyleNone

        .Color = -16776961

        .TintAndShade = 0

        .ThemeFont = xlThemeFontMinor

    End With

    With ActiveCell.Characters(Start:=3, Length:=1).Font

        .Name = "Calibri"

        .FontStyle = "Normal"

        .Size = 11

        .Strikethrough = False

        .Superscript = False

        .Subscript = False

        .OutlineFont = False

        .Shadow = False

        .Underline = xlUnderlineStyleNone

        .ThemeColor = xlThemeColorLight1

        .TintAndShade = 0

        .ThemeFont = xlThemeFontMinor

    End With

    With ActiveCell.Characters(Start:=4, Length:=1).Font

        .Name = "Calibri"

        .FontStyle = "Normal"

        .Size = 11

        .Strikethrough = False

        .Superscript = False

        .Subscript = False

        .OutlineFont = False

        .Shadow = False

        .Underline = xlUnderlineStyleNone

        .Color = -16776961

        .TintAndShade = 0

        .ThemeFont = xlThemeFontMinor

    End With

    With ActiveCell.Characters(Start:=5, Length:=1).Font

        .Name = "Calibri"

        .FontStyle = "Normal"

        .Size = 11

        .Strikethrough = False

        .Superscript = False

        .Subscript = False

        .OutlineFont = False

        .Shadow = False

        .Underline = xlUnderlineStyleNone

        .ThemeColor = xlThemeColorLight1

        .TintAndShade = 0

        .ThemeFont = xlThemeFontMinor

    End With

    With ActiveCell.Characters(Start:=6, Length:=7).Font

        .Name = "Calibri"

        .FontStyle = "Normal"

        .Size = 11

        .Strikethrough = False

        .Superscript = False

        .Subscript = False

        .OutlineFont = False

        .Shadow = False

        .Underline = xlUnderlineStyleNone

        .Color = -16776961

        .TintAndShade = 0

        .ThemeFont = xlThemeFontMinor

    End With

    With ActiveCell.Characters(Start:=13, Length:=4).Font

        .Name = "Calibri"

        .FontStyle = "Normal"

        .Size = 11

        .Strikethrough = False

        .Superscript = False

        .Subscript = False

        .OutlineFont = False

        .Shadow = False

        .Underline = xlUnderlineStyleNone

        .ThemeColor = xlThemeColorLight1

        .TintAndShade = 0

        .ThemeFont = xlThemeFontMinor

    End With

    With ActiveCell.Characters(Start:=17, Length:=7).Font

        .Name = "Calibri"

        .FontStyle = "Normal"

        .Size = 11

        .Strikethrough = False

        .Superscript = False

        .Subscript = False

        .OutlineFont = False

        .Shadow = False

        .Underline = xlUnderlineStyleNone

        .Color = -16776961

        .TintAndShade = 0

        .ThemeFont = xlThemeFontMinor

    End With

    With ActiveCell.Characters(Start:=24, Length:=4).Font

        .Name = "Calibri"

        .FontStyle = "Normal"

        .Size = 11

        .Strikethrough = False

        .Superscript = False

        .Subscript = False

        .OutlineFont = False

        .Shadow = False

        .Underline = xlUnderlineStyleNone

        .ThemeColor = xlThemeColorLight1

        .TintAndShade = 0

        .ThemeFont = xlThemeFontMinor

    End With

    With ActiveCell.Characters(Start:=28, Length:=2).Font

        .Name = "Calibri"

        .FontStyle = "Normal"

        .Size = 11

        .Strikethrough = False

        .Superscript = False

        .Subscript = False

        .OutlineFont = False

        .Shadow = False

        .Underline = xlUnderlineStyleNone

        .Color = -16776961

        .TintAndShade = 0

        .ThemeFont = xlThemeFontMinor

    End With

    With ActiveCell.Characters(Start:=30, Length:=19).Font

        .Name = "Calibri"

        .FontStyle = "Normal"

        .Size = 11

        .Strikethrough = False

        .Superscript = False

        .Subscript = False

        .OutlineFont = False

        .Shadow = False

        .Underline = xlUnderlineStyleNone

        .ThemeColor = xlThemeColorLight1

        .TintAndShade = 0

        .ThemeFont = xlThemeFontMinor

    End With

    Range("A3").Select

End Sub

"Si 1 palabra no aparece no se le cambia el color"

 ----+----1----+----2----+----3----+----4----+----

Sub ...

    With ActiveCell.Characters(Start:= 1, Length:= 0).Font

    With ActiveCell.Characters(Start:= 1, Length:= 2).Font

    With ActiveCell.Characters(Start:= 3, Length:= 1).Font

    With ActiveCell.Characters(Start:= 4, Length:= 1).Font

    With ActiveCell.Characters(Start:= 5, Length:= 1).Font

    With ActiveCell.Characters(Start:= 6, Length:= 7).Font

    With ActiveCell.Characters(Start:=13, Length:= 4).Font

    With ActiveCell.Characters(Start:=17, Length:= 7).Font

    With ActiveCell.Characters(Start:=24, Length:= 4).Font

    With ActiveCell.Characters(Start:=28, Length:= 2).Font

    With ActiveCell.Characters(Start:=30, Length:=19).Font

End Sub

For a=1 To N

    ...

    With ActiveCell.Characters(Start:=Posic, Length:=Long).Font

        ...

    End Wind

Next

Sub Poner_Rojo()

    Dim Texto_1 As String, Pos As Integer, Tabla() As String, _

        Texto_2 As String, Lng As Integer, a As Byte

    Texto_1 = Range("A1")

    Texto_2 = Range("A2")

    Tabla = Split(Texto_2, " ")

    Range("F3:F12").Select

    Selection.ClearContents

    For a = 1 To UBound(Tabla)

        Pos = InStr(UCase(Texto_1), UCase(Tabla(a)))

        If Pos > 0 Then Cells(a + 2, "F") = Tabla(a)

    Next

    Range("A2").Select

    ActiveCell.FormulaR1C1 = Texto_2

    For a = 1 To UBound(Tabla)

        If InStr(UCase(Texto_1), UCase(Tabla(a))) > o Then

            Pos = InStr(" " & Texto_2 & " ", " " & Tabla(a) & " ")

            If Pos > 0 Then

               Pos = Pos - 1

                Lng = Len(Tabla(a)) + 2

                With ActiveCell.Characters(Start:=Pos, Length:=Lng).Font

                    .Color = -16776961

                End With

            End If

        End If

    Next

End Sub

Sub Siguiente()

    Range("C4:C31").Select

    Selection.Copy

    Range("C2").Select

    ActiveSheet.PasteSpecial Format:=3, _

                             Link:=1, _

                             DisplayAsIcon:=False, _

                             IconFileName:=False

    Range("C3").Select

    Selection.Copy

    Range("A2").Select

    ActiveSheet.PasteSpecial Format:=3, _

                             Link:=1, _

                             DisplayAsIcon:=False, _

                             IconFileName:=False

    Dim Texto_1 As String, Pos As Integer, Tabla() As String, _

        Texto_2 As String, Lng As Integer, a As Byte

    Texto_1 = Range("A1")

    Texto_2 = Range("A2")

    Tabla = Split(Texto_2, " ")

    Range("F3:F12").Select

    Selection.ClearContents

    For a = 0 To UBound(Tabla)

        Pos = InStr(UCase(Texto_1), UCase(Tabla(a)))

        If Pos > 0 Then Cells(a + 2, "F") = Tabla(a)

    Next

    Range("A2").Select

    ActiveCell.FormulaR1C1 = Texto_2

    For a = 0 To UBound(Tabla)

        If InStr(UCase(Texto_1), UCase(Tabla(a))) > o Then

            Pos = InStr(" " & Texto_2 & " ", " " & Tabla(a) & " ")

            If Pos > 0 Then

               Pos = Pos - 1

                Lng = Len(Tabla(a)) + 2

                If a = 0 Then Lng = Lng - 1

                With ActiveCell.Characters(Start:=Pos, Length:=Lng).Font

                    .Color = -16776961

                End With

            End If

        End If

    Next

    Range("A1").Select

End Sub