Private Sub Worksheet_Change(ByVal Target As Range)
Dim s$, m(), c As Range
If Target.Column = 1 Then
    s = Target
    Application.EnableEvents = 0: Application.Calculation = xlCalculationManual
    With Sheets("Расценки")
    Set c = .Columns("A:A").Find(What:=s, After:=.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:= _
            xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    If c Is Nothing Then Exit Sub
    If Len(c) = 0 Then Exit Sub
    ReDim m(1 To Len(s), 1 To 12)
        For i = 1 To Len(s)
            With c.Characters(Start:=i, Length:=1).Font
                m(i, 1) = .Name
                m(i, 2) = .FontStyle
                m(i, 3) = .Size
                m(i, 4) = .Strikethrough
                m(i, 5) = .Superscript
                m(i, 6) = .Subscript
                m(i, 7) = .OutlineFont
                m(i, 8) = .Shadow
                m(i, 9) = .Underline
                m(i, 10) = .Color
                m(i, 11) = .TintAndShade
                m(i, 12) = .ThemeFont
            End With
        Next
        
        For i = 1 To Len(s)
            With Target.Characters(Start:=i, Length:=1).Font
                .Name = m(i, 1)
                .FontStyle = m(i, 2)
                .Size = m(i, 3)
                .Strikethrough = m(i, 4)
                .Superscript = m(i, 5)
                .Subscript = m(i, 6)
                .OutlineFont = m(i, 7)
                .Shadow = m(i, 8)
                .Underline = m(i, 9)
                .Color = m(i, 10)
                .TintAndShade = m(i, 11)
                .ThemeFont = m(i, 12)
            End With
        Next
    End With
    Application.EnableEvents = 1: Application.Calculation = xlCalculationAutomatic
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim s$, m(), c As Range
If Target.Column = 1 Then
    s = Target
    Application.EnableEvents = 0: Application.Calculation = xlCalculationManual
    With Sheets("Расценки")
        Set c = .Columns("A:A").Find(What:=s, After:=.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:= _
                xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        If c Is Nothing Then Exit Sub
        If Len(c) = 0 Then Exit Sub
        c.Copy Target
    End With
    Application.EnableEvents = 1: Application.Calculation = xlCalculationAutomatic
End If
End Sub