count the specific shapes on excel by VBA-CodePudding

VBA programmers,

I developed Excel Macro to appear the shapes and count them by categories depending on data entry for example :

until now the shapes are appeared Based on data entry, I can't count the shapes by categories .

this an example of what I need: my try:

MsgBox ActiveSheet.Shapes.Count

this try can just appear all the shapes instead of I need to count the specific shapes as I explained above. thank you very much and kind regards

CodePudding user response：

Solution

The UDF provides either an array or a single string based on the criteria that you are looking for, see attached gif

Sub Exec_ListShapes()
'I'd assume for some subprocess you already have the length of categories, for this purpose I'll just declare them
Dim ArrTxtCategories(1) As String: ArrTxtCategories(0) = "CategoryA_": ArrTxtCategories(1) = "CategoryB_"
Dim CounterArrTxtCategories As Long
Dim VarArrTxtShapeNames As Variant
Dim CounterVarArrTxtShapeNames As Long
Dim NumColToWrite As Long, NumRowToWrite As Long
    With Sheets("Sheet1")
    .Cells(1, 1).Value = "Shapes"
    For CounterArrTxtCategories = 0 To UBound(ArrTxtCategories)
    NumColToWrite = .Cells(1, .Columns.Count).End(xlToLeft).Column   1
    .Cells(1, NumColToWrite).Value = ArrTxtCategories(CounterArrTxtCategories)
    VarArrTxtShapeNames = Return_VarTxtShapeNames(ArrTxtCategories(CounterArrTxtCategories), .Name, True)
    For CounterVarArrTxtShapeNames = 0 To UBound(VarArrTxtShapeNames)
    NumRowToWrite = .Cells(.Rows.Count, NumColToWrite).End(xlUp).Row   1
    .Cells(NumRowToWrite, NumColToWrite).Value = Replace(VarArrTxtShapeNames(CounterVarArrTxtShapeNames), ArrTxtCategories(CounterArrTxtCategories), "")
    .Cells(NumRowToWrite, 1).Value = "Shapes Name"
    Next CounterVarArrTxtShapeNames
    Erase VarArrTxtShapeNames
    Next CounterArrTxtCategories
    End With
End Sub
Function Return_VarTxtShapeNames(TxtKeyWord As String, TxtSheetToLookIn As String, IsNeededAsArray As Boolean)
Dim ItemShape As Shape
Dim TxtDummy As String
    For Each ItemShape In Sheets(TxtSheetToLookIn).Shapes
    If InStr(ItemShape.Name, TxtKeyWord) > 0 Then TxtDummy = IIf(TxtDummy = "", ItemShape.Name, TxtDummy & "||" & ItemShape.Name)
    Next ItemShape
    If IsNeededAsArray = True And TxtDummy <> "" Then ' 1. If IsNeededAsArray = True And TxtDummy <> ""
    Return_VarTxtShapeNames = Split(TxtDummy, "||")
    Else ' 1. If IsNeededAsArray = True And TxtDummy <> ""
    Return_VarTxtShapeNames = TxtDummy
    End If ' 1. If IsNeededAsArray = True And TxtDummy <> ""
End Function