PDA

View Full Version : [SOLVED] VB Excel, Count shapes with same color



ooitzechyi
09-08-2016, 11:33 PM
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
09-09-2016, 09:16 AM
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
09-12-2016, 08:23 PM
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
09-12-2016, 08:44 PM
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
09-13-2016, 02:35 AM
Dear SamT,
Manage to get the shapes count! Thank you very much~~~