Microsoft 365 Comment rechercher des occurrences inconnues

[lucarn]

Bonjour,
Je réédite ma question sous une forme nouvelle parce que j'avais mal posé le problème et que je ne parviens pas à transformer le code qu'on m'a donné pour l'adapter à mon question.
Voici mon problème. Dans un fichier, j’ai plusieurs feuilles qui correspondent au même formulaire. En général, je me sers de listes déroulantes pour beaucoup de cellules. Mais, j’en ai quelques-unes à remplir à la main qui correspondent à des questions ouvertes. Lorsque je fais la synthèse des formulaires, je parviens facilement à compter les occurrences lorsqu’elles viennent de listes déroulantes parce que je connais toutes les possibilités. Mais lorsque la réponse est « ouverte », je ne connais pas les occurrences qui ont été créées.
J’aurai voulu une macro qui aille chercher les différentes occurrences (qui sont toujours à la même place), et lorsqu’une occurrence sort plusieurs fois, savoir combien de fois elle est sortie.
J'ajoute une précision qui n'était pas dans mon premier sujet : il n'y a qu'une cellule concernée par feuille, mais il y a un nombre de feuilles indéterminé. Donc, le fichier que je mets en pièce jointe est à 4 fiches mais il pourrait être de 10 ou de 30.
Tous les onglets s'appellent "fiche etc"
Ci-joint un fichier test avec le résultat attendu dans l'onglet synthèse

 

[pierrejean]

Bonjour lucarn

a tester:
la feuille Synthèse se met à jour à l'activation

 

[Hervé]

salut

juste pour saluer pierrejean

j'adore ces codes :

Sub synthese()
Set dico = CreateObject("Scripting.dictionary")
For Each sh In Sheets
  If sh.Name <> "Synthèse" Then
     For n = 2 To sh.Range("A" & Rows.Count).End(xlUp).Row
         dico(Trim(sh.Range("A" & n))) = dico(Trim(sh.Range("A" & n))) + 1
     Next
  End If
Next
a = dico.keys
b = dico.items
For n = LBound(a) To UBound(a)
 Sheets("Synthèse").Range("B" & n + 2) = a(n)
 Sheets("Synthèse").Range("C" & n + 2) = b(n)
Next
End Sub

c'est clair, limpide

merci

 

[mapomme]

Bonsoir à @lucarn, @pierrejean , @Hervé

Pour le fun, une version sans dictionary (pour les possesseurs d'une machine Apple). La synthèse est mise à jour quand on sélectionne la feuille "Synthèse".
Le code:

Private Sub Worksheet_Activate()
Dim sh, Indice As New Collection, x, aux, i&
On Error Resume Next
   For Each sh In ThisWorkbook.Worksheets
      If LCase(Trim(sh.Name)) Like "fiche #*" Then
         x = LCase(Application.Trim(sh.Range("a2"))): aux = Empty: aux = Indice(x)
         If IsEmpty(aux) Then Indice.Add Array(x, 1), x Else aux(1) = aux(1) + 1: Indice.Remove x: Indice.Add aux, x
      End If
   Next sh
On Error GoTo 0
   Worksheets("Synthèse").Range("b2:c" & Rows.Count).ClearContents
   If Indice.Count < 1 Then Exit Sub
   ReDim r(1 To Indice.Count, 1 To 2)
   For i = 1 To Indice.Count: aux = Indice.Item(i): r(i, 1) = aux(0): r(i, 2) = aux(1): Next
   Worksheets("Synthèse").Range("b2").Resize(Indice.Count, 2) = r
End Sub

 

[lucarn]

Bonjour lucarn

a tester:
la feuille Synthèse se met à jour à l'activation

Merci pierrejean. Bonne journée

 

[lucarn]

Bonsoir à @lucarn, @pierrejean , @Hervé

Pour le fun, une version sans dictionary (pour les possesseurs d'une machine Apple). La synthèse est mise à jour quand on sélectionne la feuille "Synthèse".
Le code:

Private Sub Worksheet_Activate()
Dim sh, Indice As New Collection, x, aux, i&
On Error Resume Next
   For Each sh In ThisWorkbook.Worksheets
      If LCase(Trim(sh.Name)) Like "fiche #*" Then
         x = LCase(Application.Trim(sh.Range("a2"))): aux = Empty: aux = Indice(x)
         If IsEmpty(aux) Then Indice.Add Array(x, 1), x Else aux(1) = aux(1) + 1: Indice.Remove x: Indice.Add aux, x
      End If
   Next sh
On Error GoTo 0
   Worksheets("Synthèse").Range("b2:c" & Rows.Count).ClearContents
   If Indice.Count < 1 Then Exit Sub
   ReDim r(1 To Indice.Count, 1 To 2)
   For i = 1 To Indice.Count: aux = Indice.Item(i): r(i, 1) = aux(0): r(i, 2) = aux(1): Next
   Worksheets("Synthèse").Range("b2").Resize(Indice.Count, 2) = r
End Sub

Merci mapomme et bonne journée