• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 330
  • Last Modified:

VBA Colouring of Shapes Is incorrect on first iteration - correct the remainder

Hi,

I have a piece of code which, given the cells selected, loops around creating shapes over the cells and colouring them dependant on a couple of other references (the value in the cell has a corresponding sheet with a category value in the identically addressed cell and a further sheet has coloured cells, one for each category). The code works fine, other than on the first iteration of the loop, the colour of the shape is set to one which is not within my list (nor anywhere on the workbook). I think it may have something to do with the fact I altered the palette to accomadate a nice list of gradations of blue, rather than the standard palette and somehow on the first loop the old color corresponding to the index I've replaced is instead used.

Here's my code:

Public Sub Main()
' ### Loop which gets the values of the selected cells, calls for shapes to be created on top of each of them _
' colours the shapes dependant on the category (with values in a corresponding sheet) and inserts the value
Dim rngSel As Range 'selection
Dim rngC As Range 'cell within selection
Dim strCAdd ' Address of native cell
Dim xlwsC ' categories worksheet
Dim intV As Double ' Value
Dim intCat As Integer 'colour category
Dim intCol As Long 'colour
Dim shp As Shape 'shape being added
Dim intFCol As Long 'font colour
Set rngSel = Selection 'set range to deal with (so even if selection changes, we're OK)
Set xlws = ActiveSheet
Set xlwsC = Worksheets("Group") 'where category data is held
For Each rngC In rngSel 'for each cell in selection
    strCAdd = rngC.Address 'get the cell ref e.g. $J$16
    intV = rngC.Value 'actual value
    intCat = xlwsC.Range(strCAdd).Value 'category value
    intCol = GetColour(intCat) 'get the cell colour corresponding to category
    intFCol = GetFColour(intCat) 'get the font colour corresponding to the category
    Set shp = PlaceShape(rngC, "OctV01" & rngC.Row & rngC.Column) 'set the shape name
    shp.Select 'select it (not sure this is nessecary)
    With shp.TextFrame
        .Characters.Text = Format(Round(intV, 1), "0.0") 'put the value in
        .HorizontalAlignment = xlHAlignCenter 'align the text (only works after text has been entered)
        .VerticalAlignment = xlVAlignCenter 'ditto
        .Characters.Font.ColorIndex = intFCol 'set font colour
        .Characters.Font.Size = 8 'set font size
    End With
    shp.Fill.ForeColor.RGB = intCol 'set internal colour
Next rngC

End Sub


Public Function GetColour(intCatV As Integer) As Long
' ### Gets the cell colour ###
Dim intR As Integer 'row
Dim xlws As Worksheet 'worksheet with coloured cells in A1:A7 with numbers in each
Set xlws = Worksheets("ColourCats") 'set it
For intR = 1 To 7 'range which colours are in
    If xlws.Range("A" & intR).Value = intCatV Then 'if there's a match
        GetColour = xlws.Range("A" & intR).Interior.Color 'get the colour
        Exit Function 'skip out
    End If
Next intR
   
End Function


Public Function GetFColour(intCatV As Integer) As Long
' ### Gets the font colour ###
Dim intR As Integer 'row
Dim xlws As Worksheet 'worksheet with coloured cells  and different fonts in A1:A7 with numbers in each
Set xlws = Worksheets("ColourCats")
For intR = 1 To 7
    If xlws.Range("A" & intR).Value = intCatV Then
        GetFColour = xlws.Range("A" & intR).Font.ColorIndex
        Exit Function
    End If
Next intR

End Function

Public Function PlaceShape(rng As Range, strName As String) As Shape
' ### creates a shape over a cell and assigns a given name ###
Dim intL As Integer 'left
Dim intT As Integer 'top
Dim intW As Integer 'width
Dim intH As Integer 'height
     'get dimensions of  range selection
    With rng
        intL = .Left
        intT = .Top
        intW = .Width
        intH = .Height
    End With
    Set PlaceShape = ActiveSheet.Shapes.AddShape(msoShapeOctagon, intL + 2, intT + 2, intW - 4, intH - 4)
    PlaceShape.Name = strName
End Function

Any suggestions gratefully welcomed.

Regards,

Rob
0
robertsmith28
Asked:
robertsmith28
  • 4
  • 4
1 Solution
 
Cory VandenbergSenior Risk ManagerCommented:
Any chance you could upload an example workbook?

WC
0
 
robertsmith28Author Commented:
Yup. How/where can I do this?
0
 
Rory ArchibaldCommented:
There's a File link that you can use to upload a file at the bottom of the text box for each post.
0
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
robertsmith28Author Commented:
Ooops, don't know how I missed that.

The code is in module "mod_CreateShapes" and I'd usually select cells l10:O15 before initiating the code in Public Sub Main


CHD-Risk-Groupsv3.xls
0
 
robertsmith28Author Commented:
I'm going to be offline for at least a few hours, sorry.
0
 
Cory VandenbergSenior Risk ManagerCommented:
That's is definitely one tricky bug.  I can't really say why it's not updating the palette color.  When I stepped through the code, if I went back to the workbook and changed sheets, it updated.  You could maybe try inserting an Activate method, but that is kind of messy, IMHO.

Instead, use a trick I actually learned from Rory while helping on another graphics example.

The property SchemeColor for the Shape object has the same palette as ColorIndex property for your Range object, but it is offset by adding 7.

Thus changed these 2 things and it will work properly (I have tested).

1. Change your .Color to .ColorIndex
------------------
Public Function GetColour(intCatV As Integer) As Long
' ### Gets the cell colour ###
Dim intR As Integer 'row
Dim xlws As Worksheet 'worksheet with coloured cells in A1:A7 with numbers in each
Set xlws = Worksheets("ColourCats") 'set it
For intR = 1 To 7 'range which colours are in
    If xlws.Range("A" & intR).Value = intCatV Then 'if there's a match
        GetColour = xlws.Range("A" & intR).Interior.ColorIndex 'get the colour
        Exit Function 'skip out
    End If
Next intR
   
End Function


2. Use the SchemeColor property for the shape object and add 7 to the ColorIndex you returned
--------------------------
shp.Fill.ForeColor.SchemeColor = intCol + 7 'set internal colour


Cheers,
WC
0
 
Cory VandenbergSenior Risk ManagerCommented:
One last thing.

I noticed your colors still didn't match your chart legend there, so I looked at your Group sheet which is setting the category for the color.  That sheet is offset by 2 rows.  You need to account for this in your code, or else add 2 rows to the top of the Group worksheet.

Adding 2 rows might be the easier fix, but if you want to edit the code to account for the offset then change

    intCat = xlwsC.Range(strCAdd).Value 'category value

to

    intCat = xlwsC.Range(strCAdd).Offset(-2, 0).Value 'category value


WC
0
 
Cory VandenbergSenior Risk ManagerCommented:
Here is your workbook, just in case.
ColorShapes.xls
0
 
robertsmith28Author Commented:
That's superb, WC, thanks ever so much. I really appreciate your effort put into this.
0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 4
  • 4
Tackle projects and never again get stuck behind a technical roadblock.
Join Now