VB Excel, Count shapes with same color

[ooitzechyi]

Hi,
I'm new with VB. Pls bare with me.
I using VB excel and trying to get the number of shapes with same color but I'm stuck.
I had assigned a macro to insert shape with fixed color selection (where there will be more than 100+ of shapes with some fixed colors in my excel sheet),
and I need to get the summary of total of shapes with same color. For example,

I have 3 red shapes, 3 green shapes and 2 yellow shapes, I wish to get the result as
Cell (2,1): 3 (Red)
Cell (3,1): 3 (Green)
Cell (4,1): 2 (Yellow)


'Code to get the shape

Private Sub Green_Click()
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, 70, 206, _
        172, 91).Select
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
        .ForeColor.RGB = vbGreen
        .BackColor.RGB = vbGreen
        .ForeColor.Brightness = 0.8
        .Solid
    End With
    With Selection.ShapeRange.Line
        .Visible = msoTrue
        .ForeColor.RGB = vbGreen
        .ForeColor.Brightness = 0.8
        .Transparency = 0
    End With
    
    With SelectShapeColor
     Unload Me
    End With
           
End Sub

'Code for Calc Number of Shape

Sub CalcShape()
 Dim sh As Sheet1
 Dim shp As Shape
 Dim vbYellow As Single
 Dim vbGrey As Single
 Dim vbRed As Single
 Dim vbGreen As Single
 Dim CountRedShape As Integer
    
        
       For Each shp In Sheet1.Shapes
                CountRedShape = 0
                If shp.Fill.ForeColor.RGB = vbRed And shp.Fill.ForeColor.Brightness = 0.8 Then
                    ActiveSheet1.Cells(2, 1) = CountRedShape + 1
                End If
        Next 

End Sub

There is no error shows but no result as well.
I'm not sure where goes wrong.
Pls helps~
Thanks

[SamT]

This is one mistake

Dim vbYellow As Single 
    Dim vbGrey As Single 
    Dim vbRed As Single 
    Dim vbGreen As Single

That sets all those VBA Constants to zero inside the sub. Delete those lines.

[ooitzechyi]

Hi SamT,
I had tried by removed those lines but it doesn't help.
I had modified the code to as below.

'Code to get the shape

Private Sub Green_Click()

    Set myDocument = Worksheets(1)
    myDocument.Shapes.AddShape(msoShapeRectangle, _
        90, 90, 90, 50).Select
    With Selection.ShapeRange.Fill
        .ForeColor.RGB = RGB(0, 300, 0)
        .BackColor.RGB = RGB(0, 300, 0)
        .TwoColorGradient msoGradientHorizontal, 1
    End With
    With Selection.ShapeRange.Line
        .ForeColor.RGB = RGB(0, 300, 0)
        .BackColor.RGB = RGB(0, 300, 0)
    End With

    With SelectShapeColor
     Unload Me
    End With

 End Sub

'Code for Calc Number of Shape

Sub CalcShape()

    Dim sh As Sheet1
    Dim shp As Shape
    Dim a As Long
    Dim b As Long
    Dim CountShape As Long

   For Each shp In Sheet1.Shapes
        CountShape = 0
        If shp.Fill.ForeColor.RGB = RGB(0, 300, 0) Then
           Sheet1.Cells(2, 1) = CountShape + 1
              End If
    Next shp

 End Sub

The result I got is "1" where actual I have 3 of similar color shapes.

[SamT]

You were: For each shape, setting Countshape to zero

Sub CalcShape() 
     
    Dim sh As Sheet1 
    Dim shp As Shape 
    Dim CountShape As Long 'Countshape is zero here
     
    For Each shp In Sheet1.Shapes 
        If shp.Fill.ForeColor.RGB = RGB(0, 300, 0) Then  CountShape = CountShape + 1 
    Next shp 

     Sheet1.Cells(2, 1) = CountShape
End Sub

BTW,the Editor # icon will insert CODE Tags, Put your code inside the tags.

[ooitzechyi]

Dear SamT,
Manage to get the shapes count! Thank you very much~~~