Count Unique Instances of Multiple Strings Using Wildcards

jpl · #1 12-04-2020, 09:19 AM

Dans la version suivante, on crée un fichier Word qui contient la liste des instance et leur nombre.
L'utilisateur peut alors sauvegarder ce fichier à l'endroit de son choix en utilisant les menus de Word.

Code:

Sub Essai()
   Dim Trouvé As String, ListeTrouvés As String
  Dim Prefixes As Variant, Prefixe As Variant
  Dim Total As Long

  'pour sortie dans un fichier Word
  Dim Fichier As Document

  ListeTrouvés = " "
  Prefixes = VBA.Array("PE-", "JEB-", "HEL-")

  For Each Prefixe In Prefixes

    With ActiveDocument.Content.Find
      .ClearFormatting
      .MatchWildcards = True
      .Text = Prefixe & "[0-9]{1,}"
      .Forward = True
      .Execute

      Do While .Found
        Trouvé = .Parent.Text
        If InStr(1, ListeTrouvés, Trouvé & " ") = 0 Then
          ListeTrouvés = ListeTrouvés & Trouvé & " "
          Total = Total + 1
        End If
        .Execute
      Loop

    End With
  Next Prefixe

  ListeTrouvés = Trim(ListeTrouvés)
  ListeTrouvés = Replace(ListeTrouvés, " ", vbCrLf)
  ListeTrouvés = ListeTrouvés & vbCrLf & "Total = " & CStr(Total)

  'Création du fichier Word de sauvegarde de la liste
  Set Fichier = Documents.Add()
  Fichier.Range.Text = "Liste à sauvegarder" & vbCrLf & ListeTrouvés
    
 End Sub

robnun · #2 12-04-2020, 09:29 AM

This is great! Thank you, jpl.

jpl · #3 12-04-2020, 12:20 PM

Dans le code de Greg Maxey, la boucle While est bien plus belle et efficace que la mienne.
Voici donc une nouvelle version qui reprend la boucle de Greg.

Code:

Sub Essai()
  Dim Trouvé As String, ListeTrouvés As String
  Dim Prefixes As Variant, Prefixe As Variant
  Dim Total As Long

  'pour sortie dans un fichier Word
  Dim Fichier As Document

  ListeTrouvés = " "
  Prefixes = Array("PE-", "JEB-", "HEL-")

  For Each Prefixe In Prefixes

    With ActiveDocument.Content.Find
    
      .ClearFormatting
      .MatchWildcards = True
      .Text = Prefixe & "[0-9]{1,}"
      .Forward = True


      Do While .Execute
        Trouvé = .Parent.Text
        If InStr(1, ListeTrouvés, Trouvé & " ") = 0 Then
          ListeTrouvés = ListeTrouvés & Trouvé & " "
          Total = Total + 1
        End If
      Loop
      
    End With
  Next Prefixe

  ListeTrouvés = Trim(ListeTrouvés)
  ListeTrouvés = Replace(ListeTrouvés, " ", vbCrLf)
  ListeTrouvés = ListeTrouvés & vbCrLf & "Total = " & CStr(Total)

  'Création du fichier Word de sauvegarde de la liste
  Set Fichier = Documents.Add()
  Fichier.Range.Text = "Liste à sauvegarder" & vbCrLf & ListeTrouvés

End Sub

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Excel Function To Count All Strings In Range	Pluviophile	Excel	1	09-21-2020 06:22 PM
Calculate recurring instances between cell count - using trigger - URGENT HELP	sfarad	Excel Programming	2	07-07-2018 07:59 AM
Count Duplicate Values without a specific Unique Value	Brittni	Excel	1	02-01-2017 06:22 PM
Count unique values that match 2 or more criteria	caeiro01	Excel	1	10-25-2015 02:34 AM
Display unique values and count the number of child items	vthomeschoolmom	Excel	2	07-25-2013 06:17 AM