Question

我在谷歌上搜索过，但我仍然无法找到解决方案。我正在寻找一些VBA代码来计算excel中不同颜色的不同形状。

示例：我在sheet1中有5个矩形形状和3个方形形状。 2个黄色矩形，3个蓝色矩形。 1个方形粉红色，2个方形黄色。我需要一个VBA代码来计算单元格中不同颜色的数字形状（黄色矩形），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

Answer 1

请尝试以下代码：

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

如何计算excel

1 个答案: