Option Explicit

Function CopyCFColor(ByVal Destination As Range, _
        Optional CopyFormatsOnly As Boolean = False, _
        Optional ConvertFunctionName As Boolean = False) As Long
    Const TmpName = "CopyCFColorTmp"
    Dim oSrc As Range, oDest As Range
    Dim oCell As Range, oCell2 As Range
    Dim oFC As FormatCondition
    Dim bR1C1 As Boolean, bOK As Boolean
    Dim f1 As String, f2 As String, f3 As String
    Dim addr As String, opr As String
    Dim b As Variant, ba As Variant
    Dim oFont As Font, oInterior As Interior, oBorder As Border
    Dim i As Long

    On Error GoTo ErrorHandler
    CopyCFColor = 1
    If ActiveSheet.FilterMode Then CopyCFColor = 2: Exit Function
    bR1C1 = Application.ReferenceStyle = xlR1C1
    ba = Array(xlLeft, xlRight, xlTop, xlBottom)

    Set oSrc = Selection.Areas(1).Cells
    Set oDest = Destination.Resize(oSrc.Rows.Count, oSrc.Columns.Count)
    oSrc.Copy
    If CopyFormatsOnly Then
        oDest.PasteSpecial xlPasteFormats
    Else
        oDest.PasteSpecial xlPasteAll
    End If

    oDest.FormatConditions.Delete

    If bR1C1 Then Application.ReferenceStyle = xlA1

    For i = 1 To oSrc.Cells.Count
        Set oCell = oSrc(i)
        Set oCell2 = oDest(i)
        If oCell.MergeCells Then
            If oCell.Address <> oCell.MergeArea(1).Address Then
                GoTo Continue
            End If
        End If

        addr = "=" & oCell.Address(False, False)
        oCell.Activate

        bOK = False
        For Each oFC In oCell.FormatConditions

            On Error Resume Next
            f1 = ""
            f2 = ""
            f1 = oFC.Formula1
            f2 = oFC.Formula2
            On Error GoTo ErrorHandler
            If Len(f1) And (Left$(f1, 1) = "=") Then f1 = Mid(f1, 2)
            If Len(f2) And (Left$(f2, 1) = "=") Then f2 = Mid(f2, 2)

            'Conversion for DOLLER, JIS and YEN function in the japanese version.
            If ConvertFunctionName Then
                If Len(f1) Then
                    ActiveWorkbook.Names.Add Name:=TmpName, RefersToLocal:="=" & f1
                    f1 = Mid(ActiveWorkbook.Names(TmpName).RefersTo, 2)
                End If
                If Len(f2) Then
                    ActiveWorkbook.Names.Add Name:=TmpName, RefersToLocal:="=" & f2
                    f2 = Mid(ActiveWorkbook.Names(TmpName).RefersTo, 2)
                End If
            End If

            If oFC.Type = xlCellValue Then
                If Len(f1) > 244 Then CopyCFColor = 3: Exit Function
                If Len(f2) > 244 Then CopyCFColor = 3: Exit Function
                Select Case oFC.Operator
                    Case xlEqual:        opr = "="
                    Case xlNotEqual:     opr = "<>"
                    Case xlGreater:      opr = ">"
                    Case xlGreaterEqual: opr = ">="
                    Case xlLess:         opr = "<"
                    Case xlLessEqual:    opr = "<="
                    Case xlBetween, xlNotBetween: opr = ""
                    Case Else: Exit Function
                End Select
                If Len(opr) Then
                    If Len(f1) Then
                        On Error Resume Next
                        If Evaluate(addr & opr & f1) Then
                            bOK = Err.number = 0
                        End If
                    End If
                Else
                    f3 = "=(" & f1 & ")>(" & f2 & ")"
                    If Len(f3) > 255 Then CopyCFColor = 3: Exit Function
                    On Error Resume Next
                    If Evaluate(f3) Then
                        If Err.number = 0 Then
                            f3 = f1: f1 = f2: f2 = f3
                        End If
                    End If
                    On Error Resume Next
                    Select Case oFC.Operator
                        Case xlBetween
                            If Evaluate(addr & ">=(" & f1 & ")") And _
                                Evaluate(addr & "<=(" & f2 & ")") Then
                                bOK = Err.number = 0
                            End If
                        Case xlNotBetween
                            If Evaluate(addr & "<(" & f1 & ")") Or _
                                Evaluate(addr & ">(" & f2 & ")") Then
                                bOK = Err.number = 0
                            End If
                    End Select
                End If
            ElseIf oFC.Type = xlExpression Then
                If Len(f1) > 254 Then CopyCFColor = 3: Exit Function
                On Error Resume Next
                If Evaluate("=" & f1) Then
                    bOK = Err.number = 0
                End If
            End If
            On Error GoTo ErrorHandler

            If bOK Then
                Set oFont = oCell2.MergeArea.Font
                With oFC.Font
                    'If Not IsNull(.Name) Then oFont.Name = .Name
                    'If Not IsNull(.Size) Then oFont.Size = .Size
                    If Not IsNull(.Bold) Then oFont.Bold = .Bold
                    If Not IsNull(.Italic) Then oFont.Italic = .Italic
                    If Not IsNull(.Underline) Then _
                        oFont.Underline = .Underline
                    If Not IsNull(.ColorIndex) Then _
                        oFont.ColorIndex = .ColorIndex
                    If Not IsNull(.Strikethrough) Then _
                        oFont.Strikethrough = .Strikethrough
                    'If Not IsNull(.Subscript) Then _
                        oFont.Subscript = .Subscript
                    'If Not IsNull(.Superscript) Then _
                        oFont.Superscript = .Superscript
                    'If Not IsNull(.Shadow) Then _
                        oFont.Shadow = oFont.Shadow
                End With

                Set oInterior = oCell2.MergeArea.Interior
                With oFC.Interior
                    If Not IsNull(.ColorIndex) Then _
                        oInterior.ColorIndex = .ColorIndex
                    If Not IsNull(.Pattern) Then _
                        oInterior.Pattern = .Pattern
                    If Not IsNull(.PatternColorIndex) Then _
                        oInterior.PatternColorIndex = .PatternColorIndex
                End With

                For Each b In ba
                    Set oBorder = oCell2.MergeArea.Borders(b)
                    With oFC.Borders(b)
                        If Not IsNull(.LineStyle) Then _
                            oBorder.LineStyle = .LineStyle
                        If Not IsNull(.Weight) Then _
                            oBorder.Weight = .Weight
                        If Not IsNull(.ColorIndex) Then _
                            oBorder.ColorIndex = .ColorIndex
                    End With
                Next
                Exit For
            End If
        Next
Continue:
    Next

    If ConvertFunctionName Then
        On Error Resume Next
        ActiveWorkbook.Names(TmpName).Delete
        On Error GoTo ErrorHandler
    End If
    If bR1C1 Then Application.ReferenceStyle = xlR1C1

    CopyCFColor = 0
    Exit Function

ErrorHandler:
    If bR1C1 Then Application.ReferenceStyle = xlR1C1
    Exit Function

End Function


Sub Test_CopyCFColor()
    Dim r As Range
    Dim lRet As Long
    On Error GoTo ErrorHandler
    If TypeName(Selection) <> "Range" Then
        MsgBox "Select the range to copy and try again.", vbExclamation
        Exit Sub
    End If
    Selection.Copy
    On Error Resume Next
    Set r = Application.InputBox(Prompt:="Select the destination cell.", Type:=8)
    On Error GoTo ErrorHandler
    If r Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    lRet = CopyCFColor(Destination:=r)
    Application.ScreenUpdating = True
    Select Case lRet
        Case 0: MsgBox "The range was copied."
        Case 2: MsgBox "Can't work in the filter mode."
        Case 3: MsgBox "Too long formula."
        Case Else: MsgBox "Error"
    End Select
    Exit Sub

ErrorHandler:
    MsgBox Err.Description, vbExclamation
End Sub