CODEWITHSUNDEEP
excelvbavba7
Reda
Reda

Reputation: 497

Count specific shapes on Excel by VBA

I developed Excel VBA code to appear the shapes and count them by categories depending on data entry.

For example:
enter image description here

Until now the shapes are appeared based on data entry.
I can't count the shapes by categories.

An example of what I need:
enter image description here

My try:

MsgBox ActiveSheet.Shapes.Count

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

Upvotes: 1

Views: 1225

Answers (1)

Sgdva
Sgdva

Reputation: 2800

Solution

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

enter image description here

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

Upvotes: 1

Related Questions