Sub Макрос3()

    Dim cell As Range, FC As FormatCondition, CStop As ColorStop
    Dim ac As Long, i As Long
    
    If MsgBox("Форматы не входящие в стандартные (гистограммы и значки), будут утеряны! Продолжить?", _
            vbExclamation + vbYesNo) <> vbYes Then Exit Sub
    
    With Application: .ScreenUpdating = False: .DisplayAlerts = False: .EnableEvents = False: ac = .Calculation: .Calculation = -4135: End With
    
    For Each cell In Selection.Cells
        If cell.FormatConditions.Count <> 0 Then
            Set FC = cell.FormatConditions(1)
            If IsNull(FC.Interior.Pattern) Then
                cell.Interior.Color = FC.Interior.Color
            ElseIf FC.Interior.Pattern = xlPatternRectangularGradient Then
                cell.Interior.Pattern = xlPatternRectangularGradient
                cell.Interior.Gradient.RectangleLeft = FC.Interior.Gradient.RectangleLeft
                cell.Interior.Gradient.RectangleRight = FC.Interior.Gradient.RectangleRight
                cell.Interior.Gradient.RectangleTop = FC.Interior.Gradient.RectangleTop
                cell.Interior.Gradient.RectangleBottom = FC.Interior.Gradient.RectangleBottom
                cell.Interior.Gradient.ColorStops.Clear
                For i = 1 To FC.Interior.Gradient.ColorStops.Count
                    Set CStop = cell.Interior.Gradient.ColorStops.Add(i - 1)
                    CStop.Color = FC.Interior.Gradient.ColorStops(i).Color
                    CStop.TintAndShade = FC.Interior.Gradient.ColorStops(i).TintAndShade
                Next i
            End If
            cell.FormatConditions.Delete
        End If
    Next cell
    
    For Each cell In Selection.Cells
        cell.Value = cell.Value
    Next cell
    
    With Application: .ScreenUpdating = True: .DisplayAlerts = True: .EnableEvents = True: .Calculation = ac: End With

End Sub