MS Excel – VBA – Copy One Cell or Range Background to another Cell or Range

I wanted to expand on my previous post MS Excel Copy Gradient from One Cell or Range to Another so i came up with the following function that can handle both Solid and Gradient background fills.

'---------------------------------------------------------------------------------------
' Procedure : CopyBkGrnd
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Copy a Cell/Range's gradient fill properties from one Cell/Range to another
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' FromRange : Range that contains the Background properties to be copied
' ToRange   : Range you wish to copy the Background properties to
'
' Usage:
' ~~~~~~
' CopyBkGrnd Range("B5"), Range("A1")
' CopyBkGrnd Sheet1.Range("B5"), Sheet2.Range("A1:B2")
'---------------------------------------------------------------------------------------
Function CopyBkGrnd(FromRange As Range, ToRange As Range)
    On Error Resume Next
    'Remove any existing settings
    ToRange.ClearFormats
    'Start Applying the new settings
    ToRange.Interior.Pattern = FromRange.Interior.Pattern
    If FromRange.Interior.Gradient.ColorStops.Count = 0 Then
        'Solid Fill Color Properties
        ToRange.Interior.PatternColorIndex = FromRange.Interior.PatternColorIndex
        ToRange.Interior.Color = FromRange.Interior.Color
        ToRange.Interior.TintAndShade = FromRange.Interior.TintAndShade
        ToRange.Interior.PatternTintAndShade = FromRange.Interior.PatternTintAndShade
    Else
        'Gradient Fill Properties
        ToRange.Interior.Gradient.RectangleLeft = FromRange.Interior.Gradient.RectangleLeft
        ToRange.Interior.Gradient.RectangleRight = FromRange.Interior.Gradient.RectangleRight
        ToRange.Interior.Gradient.RectangleTop = FromRange.Interior.Gradient.RectangleTop
        ToRange.Interior.Gradient.RectangleBottom = FromRange.Interior.Gradient.RectangleBottom
        ToRange.Interior.Gradient.Degree = FromRange.Interior.Gradient.Degree
        ToRange.Interior.Gradient.ColorStops.Clear

        For i = 1 To FromRange.Interior.Gradient.ColorStops.Count
            With ToRange.Interior.Gradient.ColorStops.Add(i - 1)
                .ThemeColor = FromRange.Interior.Gradient.ColorStops(i).ThemeColor
                .TintAndShade = FromRange.Interior.Gradient.ColorStops(i).TintAndShade
                .Color = FromRange.Interior.Gradient.ColorStops(i).Color
            End With
        Next i
    End If
End Function

One response on “MS Excel – VBA – Copy One Cell or Range Background to another Cell or Range”

  1. david

    Thanks it was really helpful… however, it doesn’t work for all possible gradient formats possible by Cell Format > Fill Effects – Those with 3 colourstops don’t copy properly as the stops must be 0, 0.5, 1.

    Here it clumsily modded but working version:

    Function CopyBkGrnd(FromRange As Range, ToRange As Range)
    On Error Resume Next
    ‘Remove any existing settings
    ToRange.ClearFormats
    ‘Start Applying the new settings
    ToRange.Interior.Pattern = FromRange.Interior.Pattern

    If FromRange.Interior.Gradient.ColorStops.Count = 0 Then
    ‘Solid Fill Color Properties
    ToRange.Interior.PatternColorIndex = FromRange.Interior.PatternColorIndex
    ToRange.Interior.Color = FromRange.Interior.Color
    ToRange.Interior.TintAndShade = FromRange.Interior.TintAndShade
    ToRange.Interior.PatternTintAndShade = FromRange.Interior.PatternTintAndShade

    ElseIf FromRange.Interior.Pattern = xlPatternLinearGradient Then
    ‘ case where a linear gradient with degree
    ToRange.Interior.Gradient.Degree = FromRange.Interior.Gradient.Degree
    ToRange.Interior.Gradient.ColorStops.Clear
    If FromRange.Interior.Gradient.ColorStops.Count = 2 Then ‘ 2 colourstops gradient
    For i = 1 To FromRange.Interior.Gradient.ColorStops.Count
    Debug.Print i
    With ToRange.Interior.Gradient.ColorStops.Add(i – 1)
    .ThemeColor = FromRange.Interior.Gradient.ColorStops(i).ThemeColor
    .TintAndShade = FromRange.Interior.Gradient.ColorStops(i).TintAndShade
    .Color = FromRange.Interior.Gradient.ColorStops(i).Color
    End With
    Next i
    ElseIf FromRange.Interior.Gradient.ColorStops.Count = 3 Then ‘ 3 colour stops!
    For i = 1 To FromRange.Interior.Gradient.ColorStops.Count
    Debug.Print i
    With ToRange.Interior.Gradient.ColorStops.Add((i – 1) / 2) ‘range 0, 0.5, 1
    .ThemeColor = FromRange.Interior.Gradient.ColorStops(i).ThemeColor
    .TintAndShade = FromRange.Interior.Gradient.ColorStops(i).TintAndShade
    .Color = FromRange.Interior.Gradient.ColorStops(i).Color
    End With
    Next i

    Else ‘some other configuration, or not needed?
    End If

    Else
    ‘Gradient Fill Properties of boxes/squares
    ToRange.Interior.Gradient.RectangleLeft = FromRange.Interior.Gradient.RectangleLeft
    ToRange.Interior.Gradient.RectangleRight = FromRange.Interior.Gradient.RectangleRight
    ToRange.Interior.Gradient.RectangleTop = FromRange.Interior.Gradient.RectangleTop
    ToRange.Interior.Gradient.RectangleBottom = FromRange.Interior.Gradient.RectangleBottom
    ‘ToRange.Interior.Pattern = FromRange.Interior.Pattern
    ToRange.Interior.Gradient.Degree = FromRange.Interior.Gradient.Degree
    ‘ToRange.Interior.Pattern = FromRange.Interior.Pattern ‘ davids mod
    ToRange.Interior.Gradient.ColorStops.Clear
    For i = 1 To FromRange.Interior.Gradient.ColorStops.Count
    Debug.Print i
    With ToRange.Interior.Gradient.ColorStops.Add(i – 1)
    .ThemeColor = FromRange.Interior.Gradient.ColorStops(i).ThemeColor
    .TintAndShade = FromRange.Interior.Gradient.ColorStops(i).TintAndShade
    .Color = FromRange.Interior.Gradient.ColorStops(i).Color
    End With
    Next i
    End If
    End Function