how to apply one gradient fill to group of cells?

[Harry Geda]

Hello,
I like to add one gradient fill to a group of cells.
I have an area of cells that are 8x14 cells.
I used conditional formatting and created conditions for solid colors.
This looks good but I need to make it with gradient fill.

After choosing a two-color design it paints the individual cells instead of
creating one gradient fill for the groupped area of cells.

How can I do the conditional formatting with Gradient fill to cover the highligted cells as one gradient fill.

Please help,
Harry

 

[pbornemeier]

To make the tint 80% transparent, change this line:

.Transparency = 0#

to this

.Transparency = 0.8

The transparency value can range from 0.00 (opaque) to 1.00 (clear)

 

[Harry Geda]

Phill,

The ".Transparency = 0.8" does not allow to see the contents in the cells behind the rectangle.
It is visible during typing but hidden after entering data.


Thank you,
Harry

 

[Harry Geda]

Phill,

Is it possible to see the cells behind a picture?

Thank you,
Harry

 

[pbornemeier]

Delete the .Transparency line mentioned previously and add:

        .GradientStops(1).Transparency = 0.8
        .GradientStops(2).Transparency = 0.8
        .GradientStops(3).Transparency = 0.8

The current version of Excel Help has far few cross-references than that of Excel 2003. Sometimes hard to find the properties and methods you know are there somewhere!!

 

[Harry Geda]

Phill,
I am getting error: 2147024809....
"Gradient stops can only be accessed on shapes with gradient fill."
What am I doing wrong?
Thank you,
Harry


Code:
-----------------------------------


Option Explicit

Sub RunMe()
' Range, Clr1 (R,G,B) , Clr2(R,G,B)
ColorBlockRGB "B5:H15", Array(204, 153, 0), Array(232, 210, 142)

End Sub

Sub ColorBlockRGB(sBlock As String, varColor1RGB As Variant, Optional varColor2RGB As Variant)

Dim sngTop As Single
Dim sngLeft As Single
Dim sngHeight As Single
Dim sngWidth As Single
Dim rngBlock As Range
Dim sItemName As String

sItemName = "CB_" & sBlock 'Delete range block if it already exists
'
On Error Resume Next
ActiveSheet.Shapes(sItemName).Delete
On Error GoTo 0

On Error GoTo ErrorHandler
Set rngBlock = Range(sBlock)
On Error GoTo 0
sngTop = Range(sBlock).Top
sngLeft = Range(sBlock).Left
sngHeight = Range(sBlock).Height
sngWidth = Range(sBlock).Width

ActiveSheet.Shapes.AddShape(msoShapeRectangle, sngLeft, sngTop, sngWidth, sngHeight).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.GradientStops(1).Transparency = 0.8
.GradientStops(2).Transparency = 0.8
.GradientStops(3).Transparency = 0.8
.ForeColor.RGB = RGB(varColor1RGB(0), varColor1RGB(1), varColor1RGB(2))
.BackColor.RGB = RGB(varColor2RGB(0), varColor2RGB(1), varColor2RGB(2))
.TwoColorGradient msoGradientVertical, 3

End With
Selection.Name = sItemName

GoTo End_Sub

ErrorHandler:
MsgBox "Range input was invalid: " & sBlock, , "Out of Range"
End_Sub:

Set rngBlock = Nothing

End Sub

 

[pbornemeier]

Put the gradient stop lines after the .twocolorgradient line

ActiveSheet.Shapes.AddShape(msoShapeRectangle, sngLeft, sngTop, sngWidth, sngHeight).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(varColor1RGB(0), varColor1RGB(1), varColor1RGB(2))
.BackColor.RGB = RGB(varColor2RGB(0), varColor2RGB(1), varColor2RGB(2))
.TwoColorGradient msoGradientVertical, 3
.GradientStops(1).Transparency = 0.8
.GradientStops(2).Transparency = 0.8
.GradientStops(3).Transparency = 0.8

 

[Harry Geda]

Phill,

Thank you for helping me.

Both text and rectangle appear washed-up.

I assume there is no way to bring the cells forward and leave the painted box as backdrop?

Thank you,
Harry

 

[pbornemeier]

Try transparency = (a larger number up to 1 to make it more transparent) for all of the color gradients, and bolding the text under the block. I don't know of a way to bring the cells forward.

Alternate (but poor) suggestion: You could copy as a picture the un-tinted range then add a gradient fill to the picture and paste that in the block.

 

[Harry Geda]

Phill,

Thank you for helping me on this.
I will try them later .

We can call this thread ended.

Regards,
Harry

 

[pbornemeier]

Last post with a little better grasp of the gradients:

Sub ColorBlockRGB(sBlock As String, varColor1RGB As Variant, Optional varColor2RGB As Variant)
 
    Dim sngTop As Single
    Dim sngLeft As Single
    Dim sngHeight As Single
    Dim sngWidth As Single
    Dim rngBlock As Range
    Dim sItemName As String
    Dim lX As Long
 
    sItemName = "CB_" & sBlock 'Delete range block if it already exists
'
    On Error Resume Next
    ActiveSheet.Shapes(sItemName).Delete
    On Error GoTo 0
 
    On Error GoTo ErrorHandler
    Set rngBlock = Range(sBlock)
    On Error GoTo 0
    sngTop = Range(sBlock).Top
    sngLeft = Range(sBlock).Left
    sngHeight = Range(sBlock).Height
    sngWidth = Range(sBlock).Width
 
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, sngLeft, sngTop, sngWidth, sngHeight).Select
    Selection.ShapeRange.Line.Weight = 0.25
    With Selection.ShapeRange.Fill
 
        .Visible = msoTrue
        .ForeColor.RGB = RGB(0, 0, 0)
        .Transparency = 0
        .TwoColorGradient msoGradientVertical, 3
        For lX = .GradientStops.Count To 3 Step -1
            .GradientStops.Delete (lX)
        Next
 
        .GradientStops(1).Color.RGB = RGB(varColor1RGB(0), varColor1RGB(1), varColor1RGB(2))
        .GradientStops(1).Position = 0#
        .GradientStops(1).Transparency = 0.6
 
        .GradientStops(2).Color.RGB = RGB(varColor2RGB(0), varColor2RGB(1), varColor2RGB(2))
        .GradientStops(2).Position = 0.5
        .GradientStops(2).Transparency = 0.9
 
        .GradientStops.Insert RGB(varColor1RGB(0), varColor1RGB(1), varColor1RGB(2)), 1
        .GradientStops(3).Transparency = 0.6
 
    End With
    Selection.Name = sItemName
 
    GoTo End_Sub
 
ErrorHandler:
    MsgBox "Range input was invalid: " & sBlock, , "Out of Range"
End_Sub:
 
    Set rngBlock = Nothing
 
End Sub