EXCEL VBA 帮忙写个代码

答：

Sub Demo()
    Dim FindRng As Range
    Dim RltRng As Range
    Dim FirstAddress As String
    Dim TempString As String
    Dim i As Integer
    
    Set FindRng = Range("B1:H6")
    With FindRng
        On Error Resume Next
        Set RltRng = .Find(what:=Range("A7").Value, lookat:=xlWhole)
        If Not RltRng Is Nothing Then
            FindRng.Interior.Pattern = xlNone
            FirstAddress = RltRng.Address
            Do
                RltRng.Interior.Color = RGB(255, 240, 100)
                Set RltRng = .FindNext(RltRng)
            Loop While Not RltRng Is Nothing And RltRng.Address <> FirstAddress
            TempString = Right(Range("I1"), 14) & "同"
        Else
            FindRng.Interior.Pattern = xlNone
            TempString = Right(Range("I1"), 14) & "否"
        End If
        On Error GoTo 0
    End With
    
    With Range("I1")
        .Value = TempString
        .Font.ColorIndex = xlAutomatic
        For i = 1 To Len(.Value)
            If Mid(.Value, i, 1) = "同" Then
                .Characters(Start:=i, Length:=1).Font.Color = -16776961
            End If
        Next i
    End With
End Sub