Office 365 Comment rechercher des occurrences inconnues

lucarn

XLDnaute Nouveau
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
 

Fichiers joints

Dernière édition:

Hervé

XLDnaute Barbatruc
salut :)

juste pour saluer pierrejean

j'adore ces codes :

VB:
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

XLDnaute Barbatruc
Supporter XLD
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:
VB:
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
 

Fichiers joints

lucarn

XLDnaute Nouveau
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:
VB:
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
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas