uitdaging : telprobleem

[Biers]

Beste mensen,

Onlangs kreeg ik onderstaande code voor het tellen van vormen :

Option Explicit
Const MijnBereik As String = "A34: DG189" 'in dit bereik worden de shapes geteld
Sub TellenBinnenBereik()
Dim i As Integer, sh As Shape
For Each sh In ActiveSheet.Shapes
If Not Intersect(Range(MijnBereik), sh.TopLeftCell) Is Nothing Then i = i + 1
Next
MsgBox "Er zijn " & i & " shapes binnen het bereik " & Range(MijnBereik).Address
End Sub

Dit is een aardige aanzet om te komen tot iets moois.
Ik heb een sheet ontwikkeld waarin ca 50 afbeeldingen (.png) zijn ingevoegd. Deze afbeeldingen staan voor bepaalde symbolen.
Door telkens op een afbeelding te klikken wordt deze in een bereik (A34: DG189) geplakt. Deze afbeeldingen hebben allemaal een specifieke naam bijvoorbeeld symbool2000. Als ik klaar ben met klikken dan is het bereik gevuld met allemaal symbolen. Stel ik heb 5x op het symbool2000 geklikt dan staat het symbool ook 5x in het bereik. Nu kan ik handmatig gaan tellen hoe vaak symbool2000 voorkomt en de uitkomst in een cel typen, maar ik ben op zoek naar een automatische telling. Door een druk op de knop moet in een bepaalde cel aangegeven worden dat symbool2000 5x voorkomt. Dus bijvoorbeeld in cel A1 staat dan 5. Bovenstaande code telt alle vormen in het bereik bij elkaar op en dat is een stap in de goede richting, maar niet wat ik zoek.
Wie heeft voor mij een oplossing.

 

[WHER]

Een poging, zie bijlage.

 

[HSV]

Probeer het zo eens Biers.

Met in B1 sh.name

Option Explicit
Const MijnBereik As String = "A4: DG189" 'in dit bereik worden de shapes geteld
Sub TellenBinnenBereik()
   Dim i As Integer, sh As Shape
     For Each sh In ActiveSheet.Shapes
       If sh.Name = [B1].Value Then
      If Not Intersect(Range(MijnBereik), sh.TopLeftCell) Is Nothing Then i = i + 1
     End If
    Next
  'MsgBox "Er zijn " & i & " shapes binnen het bereik " & Range(MijnBereik).Address
  [A1] = i & " X " & [B1]
End Sub

Edit: WHER was me al voor zie ik.

 

[Biers]

@Harry : bedankt voor je inbreng, maar wat WHER aan heeft gereikt is voor mij geschikter. Wellicht dat je nog mee kunt denken voor het onderstaande.

Ik heb inmiddels de code iets aangepast en toegepast in bijgevoegd bestand. Wat ik nu nog graag zou willen is dat middels 1 knop alle tellingen worden uitgevoerd. Met de eerste knop wordt de code uitgevoerd waarbij de totalen van symbool A uit het bereik A34: DG189 in cel AE1029 wordt geplaatst. Aan deze knop moet dus worden toegevoegd de code voor de telling van symbool B en alle overige symbolen die er straks onder komen te staan (staan nu niet in het voorbeeld, omdat het bestand dan te groot werd. Er zijn nl bijna 50 symbolen). Knop 2 is voor het tweede bereik A223 : DG378 die de waarde plaatst in cel AK1029.
Het ultieme is dat de tweede knop niet nodig is, maar dat met 1 knop voor alle bereiken en alle symbolen de waarden in de juiste cel komen te staan.

De eerste poging is al geslaagd en ik hoop dat wat ik hierboven vraag ook gaat lukken.

 

[cow18]

met die samengevoegde cellen valt dat moeilijk weg te schrijven in AE1029 etc, dus iets verder weggeschreven

Sub AlleShapesTellen()
  Dim Namen As Variant, naam As Variant, Bereiken As Variant, bereik As Variant, Aantallen() As Integer, bNaam As Boolean, sh As Shape, i As Integer, j As Integer
  Namen = Array("A", "B")                             'beginletter(s) van de namen van je shapes
  Bereiken = Array("A34:DG189", "A223:DG378", "A412:DG567", "A601:DG756", "A790:DG945")  ' de verschillende bereiken
  ReDim Aantallen(0 To UBound(Bereiken), 0 To UBound(Namen))  'telarray klaar maken

  For Each sh In ActiveSheet.Shapes                        'loop 1 voor 1 iedere shape af
    If sh.Type = 6 Then                                    'shape-type = groep
      j = 0: bNaam = False                                 'alles resetten
      For Each naam In Namen                               'zoek in alle namen
        If InStr(1, sh.Name, naam) <> 0 Then bNaam = True: Exit For  'komen beginletters overeen ? dan verder gaan naar 2e deel
        j = j + 1                                          'teller naam
      Next
      If bNaam Then                                        'overeenkomstige naam gevonden
        i = 0                                              'resetten
        For Each bereik In Bereiken                        'loop alle bereiken af
          If Not Intersect(Range(bereik), sh.TopLeftCell) Is Nothing Then Aantallen(i, j) = Aantallen(i, j) + 1  'valt topcel in bereik, dan aantal+1
          i = i + 1                                        'volgend bereik
        Next
      End If
    End If
  Next
  Range("FB1031").Resize(UBound(Aantallen) + 1, UBound(Aantallen, 2) + 1).Value = Aantallen  'schrijf aantallen weg
  Range("FB1030").Resize(, UBound(Aantallen, 2) + 1) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Namen))  'schrijf beginletters weg erboven
  Range("FA1031").Resize(UBound(Aantallen) + 1) = WorksheetFunction.Transpose(Bereiken)  'schrijf bereiken links ervan weg
  Range("FA1030").Resize(, UBound(Aantallen, 2) + 2).EntireColumn.AutoFit
End Sub

 

[Biers]

Beste cow18,

Waanzinnig. De eerste resultaten zijn verbluffend. Ik hem verder uitbreiden en testen.
Als ie helemaal klaar dan meld ik me wel.

 

[Biers]

Het werkt!

Beste allen,

Bedankt voor de inbreng. Het werkt.