Filter ShapeCount for Grouped Shape

[ooitzechyi]

Hi,
I'm facing error when I try to filter grouped shapes by their area.
Error prompt when there is grouped shape in my worksheet, it works perfect when the shape is ungroup.

Private Sub Submit_Click()
Dim xx As Integer
Dim oMyGroup As Shape
Dim shp As Shape

xx = 1
Sheet1.Cells(2, 1).Resize(4).ClearContents
'Sheet1.Shapes.SelectAll

For Each ShapeRange In Sheet1.Shapes
ShapeWidth = ShapeRange.Width / 72
ShapeHeight = ShapeRange.Height / 72
ShapeArea = ShapeWidth * ShapeHeight

If ShapeArea >= TextBox1.Text Then

For Each shp In Sheet1.Shapes
If shp.Type = msoGroup Then
Set shprange = shp.Ungroup
Set oMyGroup = shprange.Group

If shprange.Fill.ForeColor.RGB = RGB(0, 255, 0) Then
CountChildShapeGreen = CountChildShapeGreen + 1
End If

End If
Next shp

If Sheet1.Shapes(xx).Fill.ForeColor.RGB = RGB(0, 255, 0) Then
CountShapeGreen = CountShapeGreen + 1
Sheet1.Cells(2, 1) = CountShapeGreen + CountChildShapeGreen
End If

For Each shp In Sheet1.Shapes
If shp.Type = msoGroup Then
Set shprange = shp.Ungroup
Set oMyGroup = shprange.Group

If shprange.Fill.ForeColor.RGB = RGB(200, 200, 200) Then
CountChildShapeGrey = CountChildShapeGrey + 1
End If

End If
Next shp

If Sheet1.Shapes(xx).Fill.ForeColor.RGB = RGB(200, 200, 200) Then
CountShapeGrey = CountShapeGrey + 1
Sheet1.Cells(3, 1) = CountShapeGrey + CountChildShapeGrey
End If

End If

xx = xx + 1

Next ShapeRange
End Sub


*P/S: The shape could be regular shape or freeform shape.

[mana]

Option Explicit

Sub test()
Dim ws As Worksheet

Set ws = Worksheets("Sheet1")

ws.Range("a1").Value = CountShp(ws, vbRed)
ws.Range("a2").Value = CountShp(ws, vbYellow)
ws.Range("a3").Value = CountShp(ws, vbGreen)

End Sub


Private Function CountShp(myWs As Worksheet, mycolor As Long)
Dim shp As Shape
Dim x As Long
Dim tmp As Long

For Each shp In myWs.Shapes
If shp.Type = msoGroup Then
For x = 1 To shp.GroupItems.Count
If shp.GroupItems(x).Fill.ForeColor.RGB = mycolor Then
tmp = tmp + 1
End If
Next
Else
If shp.Fill.ForeColor.RGB = mycolor Then
tmp = tmp + 1
End If
End If
Next

CountShp = tmp

End Function

[ooitzechyi]

Hi mana,
Thanks but sorry, I can't get it (sorry, I have limited knowledge on VB).
I have shapes with different colors and group/ungroup in one worksheet.
I need to get the shapes to be count in as below
Let's say I have below type of shapes in my worksheet
1 grouped shapes (3 freeform shapes with 1 blue color (Area: 3m2)and 2 green color (Area: 2m2, 3m2))
2 ungrouped green shapes (Area: 3m2, 4m2)

And I want to get the no of shapes with area >=3m2
So my expected result will be
Blue: 1
Green: 3

I could get the shapes count (grouped/ungrouped with same colors) with no problem, but when I try to add-in filter shape area/grouped shapes with different colors, I got stuck................

[mana]

Option Explicit

Sub test()
Dim ws As Worksheet

Set ws = Worksheets("Sheet1")

ws.Range("a1").Value = CountShp(ws, vbRed)
ws.Range("a2").Value = CountShp(ws, vbYellow)
ws.Range("a3").Value = CountShp(ws, vbGreen)

End Sub


Private Function CountShp(myWs As Worksheet, mycolor As Long)
Dim shp As Shape
Dim gi As Shape
Dim tmp As Long

For Each shp In myWs.Shapes
If shp.Type = msoGroup Then
For Each gi In shp.GroupItems
If gi.Fill.ForeColor.RGB = mycolor Then
If (gi.Width / 72) * (gi.Height / 72) >= 3 Then
tmp = tmp + 1
End If
End If
Next
Else
If shp.Fill.ForeColor.RGB = mycolor Then
If (shp.Width / 72) * (shp.Height / 72) >= 3 Then
tmp = tmp + 1
End If
End If
End If
Next

CountShp = tmp

End Function

[ooitzechyi]

Hi mana,
Thanks a lot~