i want to find and hightlight a specific word in a excel, but the whole cell is getting highlighted pls help me

First of, try to tidy a bit your code example, it's quite messy hence I am not sure of what you are actualy trying to achieve. Some acompaniying comments would help also

Anyway, one thing is for sure :

rng.Characters.Font.ColorIndex = 3

will attribute a color to the whole text in the selected range. To specify only a subset of the text in the range, you need to use :

rng.Characters(Start:=x, Length:=y).Font.ColorIndex = 3

Where x being the starting character and Length being the length that you want to turn into the given font color.

You can find the start value and length using

start = InStr(1, rng, MyAr(i))
length = len(MyAr(i))

Which will lead to the following line

rng.Characters(Start:=start, Length:=length).Font.ColorIndex = 3

And as specified by FaneDuru, it should be done on a cell by cell basis. Either you do it instead of the Union, or you look on the cells within the rng.

for cell in rng.Cells
    start = InStr(1, cell, MyAr(i))
    ...
next cell

Moreover, as described here, it will only color the first occurence.

If the value you are looking for can appear several time, you either need an alternate way or set some itteration until there are no more matches by modifying the starting position in the InStr where 1 would become the last matched position + 1

Please, try the next updated code. As I said in my above comment you cannot use a Union range for what you try doing, because you need to search for each cell and find the appropriate cell characters to be colored. You can iterate between such a range again but nothing will be gain:

Dim fnd As String, FirstFound As String, MyAr, i As Long, pos As Long
Dim FoundCell As Range, LastCell As Range, myRange As Range

Set myRange = ActiveSheet.UsedRange
Set LastCell = myRange.cells(myRange.cells.count)

fnd = "university/checklist"

MyAr = Split(fnd, "/")

    For i = LBound(MyAr) To UBound(MyAr)

        Set FoundCell = myRange.Find(MyAr(i)), , , xlPart

        If Not FoundCell Is Nothing Then
            FirstFound = FoundCell.Address
            pos = InStr(1, FoundCell.Value, MyAr(i), vbTextCompare)
            FoundCell.Characters(pos, Len(MyAr(i))).Font.ColorIndex = 3
            
            Do
                Set FoundCell = myRange.FindNext(FoundCell)
                 pos = InStr(1, FoundCell.Value, MyAr(i))
                 FoundCell.Characters(pos, Len(MyAr(i))).Font.ColorIndex = 3
            Loop While FoundCell.Address <> FirstFound
       End If
    Next i
End Sub

If the range to be processed is large, you should use some optimization lines as Application.ScreenUpdating = False, Application.EnableEvents = False and Application.Calculation = xlManual at the beginning of the code and ending with Application.ScreenUpdating = False, Application.EnableEvents = False and Application.Calculation = xlCalculationAutomatic

Highlight Strings in Cells

Option Explicit

Sub HighlightStrings()
    
    Const CriteriaList As String = "university,checklist"
    Const CriteriaColor As Long = vbRed

    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    Dim rg As Range: Set rg = ws.UsedRange

    Dim Criteria() As String: Criteria = Split(CriteriaList, ",")
    
    Dim c As Long
    Dim cLen As Long
    Dim cString As String
    
    Dim fCell As Range
    Dim fArr() As String
    Dim f As Long
    Dim fPos As Long
    Dim fString As String
    Dim fFirstAddress As String
    
    For c = 0 To UBound(Criteria)
        cString = Criteria(c)
        cLen = Len(cString)
        Set fCell = rg.Find(cString, , xlFormulas, xlPart)
        If Not fCell Is Nothing Then
            fFirstAddress = fCell.Address
            Do
                fString = fCell.Value
                fPos = 1
                fArr = Split(fString, cString, , vbTextCompare)
                For f = 0 To UBound(fArr) - 1
                    fPos = fPos + Len(fArr(f))
                    fCell.Characters(fPos, cLen).Font.Color = CriteriaColor
                    fPos = fPos + cLen
                Next f
                Set fCell = rg.FindNext(fCell)
            Loop Until fCell.Address = fFirstAddress
        End If
    Next c
    
    MsgBox "Criteria strings highlighted.", vbInformation

End Sub