Count specific shapes on Excel by VBA

Question

I developed Excel VBA code 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.

An example of what I need:

My try:

MsgBox ActiveSheet.Shapes.Count

This counts all the shapes.
Instead I need to count the specific shapes.

Do you want the macro to count shapes names with specific names? Like count shapes named "AB1"? Or do you have a key word to spot categories and would like the macro to list these (IE: CategoryA_AB1)? — Sgdva, Jun 08 '22 at 16:51
@Sgdva,@SJR dears, Please see the update above and Many thanks — Reda, Jun 08 '22 at 21:06
Is the expected result the complete table or just the two numbers? Is it `DC` or `CD`? Will you be comparing the left part of the name against e.g. `CategoryA` or the right part e.g. `AB1` against the values in the table? Why don't you share the code you've got so far which could clarify some of the issues. — VBasic2008, Jun 09 '22 at 10:08

score 1 · Accepted Answer · answered Jun 09 '22 at 15:07

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

Count specific shapes on Excel by VBA

1 Answers1