Full Version: Excel VBA - Copy Gradient/fill From 1 Cell To Another
UtterAccess Discussion Forums > Microsoft® Office > Microsoft Excel
ahpitre
I need to copy the Gradient/Fill from 1 cell to another via VBA. Tried using the different options from Range.Interior.... like .Gradient, .Patter, .PatterIndexColor, etc., the full Gradient/Fill color of the cell is not being copied to the other cell. I cannot use the Copy/Paste Special formats, as both cells have different formats (Wrap Text, Merge, Font Size, etc.). Is there a way to successfully coypy the background of a cell that uses Gradient, to another cell via VBA? If Gradient were not present, then following line works OK :

shtSheet.Range(rngRange.Name).Interior.Color = shtSheet.Range(strEvent_Cell).Interior.Color

The line above only works well when Cell background doesn't use Gradient, just solid colors, if the cell uses Gradient, then the above line sets the receiving cell to black.

These are the VBA lines I am trying to apply the a Gradient,

shtSheet.Range(rngRange.Name).Interior.PatternColor = shtSheet.Range(strEvent_Cell).Interior.PatternColor
shtSheet.Range(rngRange.Name).Interior.PatternColor2 = shtSheet.Range(strEvent_Cell).Interior.PatternColor2
shtSheet.Range(rngRange.Name).Interior.PatternColorIndex = shtSheet.Range(strEvent_Cell).Interior.PatternColorIndex
shtSheet.Range(rngRange.Name).Interior.PatternTintAndShade = shtSheet.Range(strEvent_Cell).Interior.PatternTintAndShade
shtSheet.Range(rngRange.Name).Interior.Pattern = shtSheet.Range(strEvent_Cell).Interior.Pattern

Also tried these, but they produce errors :
shtSheet.Range(rngRange.Name).Interior.Gradient = shtSheet.Range(strEvent_Cell).Interior.Gradient
shtSheet.Range(rngRange.Name).Interior.PatternThemeColor = shtSheet.Range(strEvent_Cell).Interior.PatternThemeColor
dflak
I did a bit of experimentation. This example has an intermediate step that you can delete, namely recording the values. But it does show which attributes to tweak.
CODE
Sub ReadColor()
Dim CellPattern As Long, CellColorIndex As Long, CellColor As Long, CellTintAndShade As Long, _
    CellPatternTintAndShade As Long
    
    With Selection.Interior
        CellPattern = .Pattern
        CellColorIndex = .PatternColorIndex
        CellColor = .Color
        CellTintAndShade = .TintAndShade
        CellPatternTintAndShade = .PatternTintAndShade
    End With
    
    MsgBox CellPattern & Chr(10) & _
        CellColorIndex & Chr(10) & _
        CellColor & Chr(10) & _
        CellTintAndShade & Chr(10) & _
        CellPatternTintAndShade
        
    With Range("A10").Interior
        .Pattern = CellPattern
        .PatternColorIndex = CellColorIndex
        .Color = CellColor
        .TintAndShade = CellTintAndShade
        .PatternTintAndShade = CellPatternTintAndShade
    End With

End Sub
ahpitre
Youre code is similar to what I already tried, and, it doesn't work for Gradient filled cells. Code works OK for cells with only 1 backgound color, and, who don't use Gradient. When you use Gradient there are other things that need to occur as a Gradient has 2 or more colors, has a pattern (Vertical, Horizontal, Diagonal, etc.), and each pattern can have 2 or more options (left to right, up moving down, etc.).

In youre code, line .Pattern copies the .Pattern but not completely (copies 1 of the colors, but leaves out another color). As soon as the .Color and .TintAndShade lines execute, you get a cell filled with black. Seems since Color/TintAndShade can only understand 1 color at a time, and, because the cell has a Gradient, then, VBA just defaults to black.
DanielPineault
I fiddled a little and quickly came up with the following which appears to work (based on limited testing):

CODE
Function CopyGradient()
On Error Resume Next
    Range("C7").ClearFormats
    Range("C7").Interior.Pattern = ActiveCell.Interior.Pattern
    Range("C7").Interior.Gradient.RectangleLeft = ActiveCell.Interior.Gradient.RectangleLeft
    Range("C7").Interior.Gradient.RectangleRight = ActiveCell.Interior.Gradient.RectangleRight
    Range("C7").Interior.Gradient.RectangleTop = ActiveCell.Interior.Gradient.RectangleTop
    Range("C7").Interior.Gradient.RectangleBottom = ActiveCell.Interior.Gradient.RectangleBottom
    Range("C7").Interior.Gradient.Degree = ActiveCell.Interior.Gradient.Degree
    Range("C7").Interior.Gradient.ColorStops.Clear

    For i = 1 To ActiveCell.Interior.Gradient.ColorStops.Count
        With Range("C7").Interior.Gradient.ColorStops.Add(i - 1)
            .ThemeColor = ActiveCell.Interior.Gradient.ColorStops(i).ThemeColor
            .TintAndShade = ActiveCell.Interior.Gradient.ColorStops(i).TintAndShade
        End With
    Next i
End Function


Definitely enough to build upon
DanielPineault
Fiddled a little more and came up with the following reusable function

CODE
Function CopyGradient(FromRange As Range, ToRange As Range)
'Usage Examples:
'CopyGradient Range("B5"), Range("A1")
'CopyGradient Sheet1.Range("B5"), Sheet2.Range("A1:B2")
On Error Resume Next
    ToRange.ClearFormats
    ToRange.Interior.Pattern = FromRange.Interior.Pattern
    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
        End With
    Next i
End Function
DanielPineault
Fiddled some more and came up with a function to copy the background, regardless of whether it is a gradient or solid color. I hope it helps.

CODE
'---------------------------------------------------------------------------------------
' 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
            End With
        Next i
    End If
End Function
ahpitre
Sorry to say that the code provided doesn't fully copy the Gradient. Weird, it copies 1 color of the Gradient, then, it completes the Gradient with White. For example, my Gradient colors are blue and purple. Code provided makes a blue/white Gradient. If you move the .Clear line to beggining of Else code block, then, you get a Black/White Gradient. Also tried playing around with the .Stops (instead of .ColorStops), but, Gradient is still not copied completely.

The only way (so far) that it works correctly (copies Gradient) is to use the format painter, but, this copies everything from 1 cell to the other. Since the receiving cell in my Workbook has a different format (merge & center, wrap text, borders, etc.) than the cell whose Gradient is being copied, this alternative is not suitable.
DanielPineault
That is odd because in all my tests, it always works?!

Any chance you can post you workbook so we can take a look?
Also, is your MS Office up-to-date (SP3)?
DanielPineault
Okay, some more testing and the issue lies only with a specific set of colors. Anyways, I think this very slightly modified version should do the trick:

CODE
'---------------------------------------------------------------------------------------
' 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
ahpitre
OK. The last code did the trick. I had to remove the 1st line ('ToRange.ClearFormats), just because it resets all formatting, and I don't need this. Thanks for your help. It has been a learning experience.

PS : Your code works for both Gradients, and regular background colors. <
This is a "lo-fi" version of our main content. To view the full version with more information, formatting and images, please click here.