如何在Excel中计算具有不同颜色的特定形状的数量
我search了谷歌，但我仍然无法find解决scheme。 我正在寻找一些VBA代码来计算在Excel中不同颜色的不同形状。
例如：我在sheet1中有5个矩形和3个正方形。 2个黄色矩形，3个蓝色矩形。 粉红色为1方形，黄色为2方形。 我需要一个VBA代码来计算单元格A1（黄色矩形），A2（蓝色矩形），B1（粉红色正方形），B2（黄色正方形）中不同颜色的数字形状。
Private Sub Worksheet_Activate() Dim shp As Shape Dim shprange As ShapeRange Dim CountyellowShape As Long Dim CountpinkShape As Long Dim CountblueShape As Long 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(255, 255, 0) Then CountChildShapeYELLOW = CountChildShapeYELLOW + 1 If shprange.Fill.ForeColor.RGB = RGB(255, 153, 153) Then CountChildShapePINK = CountChildShapePINK + 1 If shprange.Fill.ForeColor.RGB = RGB(0, 176, 240) Then CountChildShapeBLUE = CountChildShapeBLUE + 1 End If Next shp For Each shp In Sheet1.Shapes If shp.Fill.ForeColor.RGB = RGB(255, 255, 0) Then CountShapeYELLOW = CountShapeYELLOW + 1 If shp.Fill.ForeColor.RGB = RGB(255, 155, 153) Then CountShapePINK = CountShapePINK + 1 If shp.Fill.ForeColor.RGB = RGB(0, 176, 240) Then CountShapeBLUE = CountShapeBLUE + 1 Next shp Sheet1.Cells(1, 1) = CountShapeYELLOW + CountChildShapeYELLOW Sheet1.Cells(2, 1) = CountShapePINK + CountChildShapePINK Sheet1.Cells(3, 1) = CountShapeBLUE + CountChildShapeBLUE End Sub 提前感谢。 Wiz Lee
尝试下面的代码：
Sub GetShapeProperties() Dim sShapes As Shape, lLoop As Long, lastRow As Long, i As Long, find As Boolean Dim wsStart As Worksheet Set wsStart = ActiveSheet 'Loop through all shapes on active sheet For Each sShapes In wsStart.Shapes lastRow = ActiveSheet.UsedRange.Rows.Count 'Increment Variable lLoop for row numbers lLoop = lLoop + 1 i = 2 With sShapes 'Add shape properties find = False Do While find = False If (wsStart.Cells(i, 1).Value = MySplitFunction(.Name)(0)) Then If (wsStart.Cells(i, 2).Value = .Fill.ForeColor.RGB) Then find = True lLoop = lLoop - 1 End If End If If i > lLoop Then find = True End If i = i + 1 Loop wsStart.Cells(i - 1, 1).Value = MySplitFunction(.Name)(0) wsStart.Cells(i - 1, 2).Value = .Fill.ForeColor.RGB wsStart.Cells(i - 1, 2).Interior.Color = .Fill.ForeColor.RGB wsStart.Cells(i - 1, 3).Value = wsStart.Cells(i - 1, 3).Value + 1 End With Next sShapes End Sub Function MySplitFunction(s As String) As String() Dim temp As String Do temp = s s = Replace(s, " ", " ") 'remove multiple white spaces Loop Until temp = s MySplitFunction = Split(Trim(s), " ") 'trim to remove starting/trailing space End Function
