Function vpr(r1 As Range, r2 As Range, c As Integer)
    If IsError(Application.VLookup(r1, r2, c, 0)) Then
        vpr = ""
        With Application.Caller
        .Parent.Evaluate "RChangeit(" & .Address(False, False) & ")"
        End With
        Exit Function
    End If
    If Application.VLookup(r1, r2, c, 0) = "" Then
        vpr = ""
    Else
        vpr = Application.VLookup(r1, r2, c, 0)
    End If
    crw = Application.Match(r1, Application.WorksheetFunction.Index(r2, 0, 1), 0)
    cii = Application.WorksheetFunction.Index(r2, crw, c).Interior.ColorIndex
    
    With Application.Caller
'        .Parent.Evaluate "rChangeit(" & .Address(False, False) & ")"
        .Parent.Evaluate "ApplyCellFormatsFromFormatConditions(" & .Address(False, False) & ", '" & r2.Parent.Name & "'!" & Application.WorksheetFunction.Index(r2, crw, c).Address & ")"
    End With
End Function

'Sub ChangeIt(c1 As Range, ci As Integer)
'    c1.Interior.ColorIndex = ci
'End Sub

Sub RChangeIt(c1 As Range)
    c1.Interior.Color = xlNone
End Sub

Private Sub ApplyCellFormatsFromFormatConditions(CellPaste As Range, CellCopy As Range)
Dim dfBorders As Object, dfFont As Object, dfInterior As Object
Dim i&
    
'    CellPaste.NumberFormat = CellCopy.NumberFormat

    '%%%%%%%%%%%%%%%%%...Borders...%%%%%%%%%%%%%%%%%%%%
    Set dfBorders = CellCopy.DisplayFormat.Borders
    With CellPaste.Borders
        For i = 1 To 4
            .Item(i).LineStyle = dfBorders.Item(i).LineStyle
            .Item(i).ColorIndex = dfBorders.Item(i).ColorIndex
        Next
    End With
    '%%%%%%%%%%%%%%%%%...Borders...%%%%%%%%%%%%%%%%%%%%

    '%%%%%%%%%%%%%%%%%...Font...%%%%%%%%%%%%%%%%%%%%
    Set dfFont = CellCopy.DisplayFormat.Font
    With CellPaste.Font
        .Color = dfFont.Color
        .Bold = dfFont.Bold
        .Italic = dfFont.Italic
        .Strikethrough = dfFont.Strikethrough
        .Underline = dfFont.Underline
        .Background = dfFont.Background
    End With
    '%%%%%%%%%%%%%%%%%...Font...%%%%%%%%%%%%%%%%%%%%
   
    '%%%%%%%%%%%%%%%%%...Interior...%%%%%%%%%%%%%%%%%%%%
    Set dfInterior = CellCopy.DisplayFormat.Interior
    With CellPaste.Interior
        If Not dfInterior.Gradient Is Nothing Then
            .Pattern = dfInterior.Pattern
            Do While .Gradient.ColorStops.Count < dfInterior.Gradient.ColorStops.Count
                .Gradient.ColorStops.Add (0)
                DoEvents
            Loop
            If .Pattern = 4001 Then
                .Gradient.RectangleLeft = dfInterior.Gradient.RectangleLeft
                .Gradient.RectangleRight = dfInterior.Gradient.RectangleRight
                .Gradient.RectangleTop = dfInterior.Gradient.RectangleTop
                .Gradient.RectangleBottom = dfInterior.Gradient.RectangleBottom
            Else
                .Gradient.Degree = dfInterior.Gradient.Degree
            End If
            For i = 1 To dfInterior.Gradient.ColorStops.Count
                .Gradient.ColorStops(i).Color = dfInterior.Gradient.ColorStops(i).Color
                .Gradient.ColorStops(i).Position = dfInterior.Gradient.ColorStops(i).Position
                If dfInterior.Gradient.ColorStops(i).ThemeColor Then _
                .Gradient.ColorStops(i).ThemeColor = dfInterior.Gradient.ColorStops(i).ThemeColor
                .Gradient.ColorStops(i).TintAndShade = dfInterior.Gradient.ColorStops(i).TintAndShade
            Next
        Else
            .Pattern = dfInterior.Pattern
            If .Pattern <> xlPatternNone Then
                .Color = dfInterior.Color
                .PatternColor = dfInterior.PatternColor
            End If
        End If
    End With
    '%%%%%%%%%%%%%%%%%...Interior...%%%%%%%%%%%%%%%%%%%%
End Sub