how to apply one gradient fill to group of cells?

H

Harry Geda

Board Regular
Joined
Mar 4, 2010
Messages
153
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
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
Sort by date Sort by votes
Add code to create a rectangle to cover the area of the cells then apply a gradient fill to it with colors based on the values of the covered cells.
 
Upvote 0
Hello Phill,

Thank you for the clue.
Do you have any guidelines or previous threads on this?

Regards,
Harry
 
Upvote 0
How do you determine what colors you want to use in the gradient? What determines the direction and type of the gradient?
 
Upvote 0
A bit of error checking is included.

Code: 
Option Explicit

Sub ColorBlock(sBlock As String, iColorIndex1 As Integer, Optional iColorIndex2 As Integer, Optional iGradientType As Integer)
    
    Dim sngTop As Single
    Dim sngLeft As Single
    Dim sngHeight As Single
    Dim sngWidth As Single
    Dim rngBlock As Range
    Dim sItemName As String
    
'   iGradientType     msoGradientHorizontal   '1
'                     msoGradientVertical     '2
'                     msoGradientDiagonalUp   '3
'                     msoGradientDiagonalDown '4
'                     msoGradientFromCorner   '5
'                     msoGradientFromTitle    '6
'                     msoGradientFromCenter   '7

'   iColorIndex has to be integer from 1 to 56 - see colors here:
'   http://www.mrexcel.com/forum/showthread.php?t=163988

    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
    
    If iColorIndex1 < 1 Or iColorIndex2 > 56 Then
        MsgBox "ColorIndex1 is out of range: " & iColorIndex1, , "Out of Range"
        GoTo End_Sub
    End If
    
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, sngLeft, sngTop, sngWidth, sngHeight).Select
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = iColorIndex1
    If iColorIndex2 > 0 And iColorIndex2 < 57 Then Selection.ShapeRange.Fill.BackColor.SchemeColor = iColorIndex2
    If iGradientType > 0 And iGradientType < 8 Then Selection.ShapeRange.Fill.TwoColorGradient iGradientType, 1
    Selection.ShapeRange.Fill.Transparency = 0#
    Selection.Name = sItemName
    
    GoTo End_Sub
    
ErrorHandler:
    MsgBox "Range input was invalid: " & sBlock, , "Out of Range"

End_Sub:
    
    Set rngBlock = Nothing
    
End Sub
 
Upvote 0
Phill,

This is major work.
Thank you very much.
The problem is that I don't understand what is what and where should i place the code and which cells to place data.

The colors associate with: $2, $3, $4 & $5 items.
The $5.0 is the gold looking. The center has a verticaly lighter area.
Left & Right color
RGB:
Red =204
Green =153
Blue =0
Center Vertical color
RGB:
Red =232
Green =210
Blue =142

Thank you,
Harry
 
Upvote 0
This works in Excel 2003, in 2007 the ceenter color is white instead of light-gold. I will work figuring out the 2007 version.

Call procedure like this:
Code: 
ColorBlockRGB "B59", Array(204, 153, 0), Array(232, 210, 142)

Code: 
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
        .Transparency = 0#
        .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
 
Upvote 0
Hello Phill,

You are doing major work while I know nothing on VBA.

Please tell me where to place each section?
I only know to right click the sheet1 and place code in there and
I think this is not as simple.

Thank you,
Harry
 
Upvote 0
Right-Click the Sheet1 tab and select View Code.
In the menu, select Insert | Module -- a module will be added and will be made visible.
Paste all of the code below into that module.
Edit the colors and range in the RunMe procedure to meet your requirements.
Close the VB Editor environment.
In Excel Press Alt+F8
Select "RunMe" from the list of macros
Click Run.

See more details in the 3rd link in my signature

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
        .Transparency = 0#
        .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
 
Upvote 0
Phill,

Thank you.
The code draws a rectangle with the center beeing white as you said it would be.

The problem is that I can not see the text behind it.
I tried to use transparency but it brightens the block and if I type anyting it dissapears behind the colored area and I can not see the text in cells.

Regards,
Harry
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question
Color gradient for cells
Replies
1
Views
310
bobsan42
bobsan42
T
  • Question
Gradient Conditional formatting
Replies
1
Views
590
MCLIFTO8
MCLIFTO8
C
  • Question
Macro to select cells between "total" rows for gradient fill
Replies
2
Views
304
CiaoKarina
C
J
  • Solved
Program Doesn't Allow Conditional Change of Font Color Without Affecting Fill
Replies
1
Views
243
jdpro
J
J
  • Question
Conditional Formatting Issue
Replies
1
Views
425
jegentry
J

Forum statistics

Threads
1,215,065
Messages
6,122,945
Members
449,095
Latest member
nmaske

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top