Shape macro

[lukemason12]

Hi all,

I am after a macro that when a button is clicked it changes the colour of a shape to say if the statement is complete, working towards or incomplete. I then need a cell to be linked to the cell so that if it is complete the cell shows 3, working towards 2, incomplete 1.

I have a macro that fills the shapes fine but I cannot work out how to make a cell change value depending on the shape colour. There are roughly 36 shapes per worksheet.

Any help would be great.

Thanks,
Luke

 

[Yongle]

Welcome to the forum

Try this
- shape linked to cell B1
- B1 value alternates between 1, 2 & 3
- shape colour alternates between Green, Blue & Red

To link a shape to cell B1 (amend to whichever cell you want to use)

- right click on any shape to select it
- in formula bar type =B1 and hit Enter key

Add this procedure to a module (amend colurs etc to whatever you prefer to use)

Sub ChangeColours()
    Dim cel As Range
    ActiveSheet.Shapes(Application.Caller).Select
    Set cel = Range(Selection.Formula)
   
        With Selection.ShapeRange.Fill.ForeColor
            Select Case .RGB
                Case RGB(255, 0, 0)
                    .RGB = RGB(0, 255, 0)
                    cel = 1
                Case RGB(0, 255, 0)
                    .RGB = RGB(0, 0, 255)
                    cel = 2
                Case Else:
                    .RGB = RGB(255, 0, 0)
                    cel = 3
            End Select
        End With
        cel.Select
End Sub

Assign procedure to shape
- right click on shape \ Assign Macro \ click on ChangeColours \ OK

 

[lukemason12]

Hmmm i dont think this would work as I need the cell to change not the shape.


If I could get the value of the shape to be the cell value I think I could get this to work but at the moment I can only get the shape to reference a cell and not vis versa.

 

[Yongle]

Please explain EXACTLY what you want the user to do and what should then happen to the shape and what should happen to the cell

 

[lukemason12]

I have a number of sheets. On each sheet there are shapes that have statements written in that need to be completed.

I have three buttons on the sheet that are assigned macros to colour the shapes to red if the statement is incomplete, orange if it is working towards and green if it has been completed.

What I want to be able to do is count how many statements have been completed, working towards or incomplete.

The easiest way would be to count the shapes but after reading a lot online it all says this can not be achieved as excel can’t see it as a colour.

So my idea was to link the shape to a cell so that when whichever button was clicked (incomplete 1, working towards 2, complete 3) a number would appear in the shape which would then be linked to a cell. This way I can then count from the cells how many 1,2 or 3s appear giving me a count on the statements.

Hope this makes sense.

Luke.

 

[Yongle]

A method to count the number of shapes containing each colour ...

1. Select the sheet containing the shapes
2. Run this macro - it creates a new sheet with the colour values of each shape

Sub GetColours()
    Application.ScreenUpdating = False
    Dim shp As Shape, ws As Worksheet, sh As Worksheet, r As Long
    Set sh = ActiveSheet
    Set ws = Worksheets.Add
    sh.Activate
    For Each shp In sh.Shapes
        shp.Select
        r = r + 1
        ws.Cells(r, 1).Resize(, 2) = Array(Selection.Name, Selection.ShapeRange.Fill.ForeColor)
    Next
    Selection.TopLeftCell.Activate
    ws.Activate
End Sub

My test include red, green, and blue shapes
The above VBA therefore returned these values
Rectangle 2 255
Rectangle 3 65280
Rectangle 4 16711680
etc

3. Next use those values and modify the macro below to count your 3 colours

Sub CountColours()
    Application.ScreenUpdating = False
    Const A = [COLOR=#ff0000]255[/COLOR], B = [COLOR=#00ff00]65280[/COLOR], C = [COLOR=#0000ff]16711680[/COLOR]
    Dim AA As Long, BB As Long, CC As Long
    Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
       shp.Select
       Select Case Selection.ShapeRange.Fill.ForeColor
          Case A: AA = AA + 1
          Case B: BB = BB + 1
          Case C: CC = CC + 1
       End Select
    Next shp
    Selection.TopLeftCell.Activate
    MsgBox AA & vbCr & BB & vbCr & CC
End Sub

 

[lukemason12]

Than you Yongle I will give this a go.

 

[lukemason12]

Hi Yondle,

This works quite well. Is there a way to paste the results onto the sheet instead of displaying it as a message box? Say cells A5,6,7.

Thanks for your help,

Luke

 

[Yongle]

Range("A5:A7") = Array(AA, BB, CC)

 

[Yongle]

Oops - half asleep
Let's try that again!

Range("A5:A7") = WorksheetFunction.Transpose(Array(AA, BB, CC))