#1
|
|||
|
|||
Count Unique Instances of Multiple Strings Using Wildcards
I am looking for a macro that will count the unique instances of multiple strings, and the find function requires wild cards.
Example: Assume the text in the Word document is: PE-15896 Blue lamps from China. PE-12 Green buckets from India. JEB-85968 Green cans from Mexico. HEL-698568 Orange phones from Peru. HEL-698568 Red boxes from Canada. (Notice HEL-698568 is used twice - this should be counted as one instance) I need to count all instances of strings that start with PE-,HEL-, and JEB- and have any number of characters after the dash. I need to generate the following: PE-15896 PE-12 JEB-85968 HEL-698568 Total Unique Records = 4 Thank you! Last edited by robnun; 12-03-2020 at 06:53 PM. |
#2
|
|||
|
|||
ceci a l'air de fonctionner, à tester !
Code:
Sub Essai() Dim i As Long, Trouvé As String, ListeTrouvés As String, Prefixes As Variant, Total As Long ListeTrouvés = " " Prefixes = Array("PE-", "JEB-", "HEL-") For i = 0 To UBound(Prefixes) With ActiveDocument.Content.Find .ClearFormatting .MatchWildcards = True .Text = Prefixes(i) & "[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 i ListeTrouvés = Trim(ListeTrouvés) ListeTrouvés = Replace(ListeTrouvés, " ", Chr(13)) Debug.Print ListeTrouvés Debug.Print "Total = " & Total End Sub |
#3
|
|||
|
|||
Thank you for your reply, Jpl.
I am receiving the following error when I run this macro: Run-time error 5560: The Find What text contains a Pattern Match expression which is not valid. I'm not sure what this means. I have attached a sample of a file for which I might use this macro. Thank you so much for your help. |
#4
|
|||
|
|||
La malédiction de la tour de Babel a encore frappé.
J'utilise une version française de Word, et le problème réside sans doute dans l'instruction Code:
.Text = Prefixe & "[0-9]{1;}" Code:
{1;} Code:
{1,} |
#5
|
|||
|
|||
J'ai fait tourner la macro sur votre document, et j'ai obtenu les résultats suivants :
PE-109689 PE-108635 PE-103905 PE-103906 PE-111642 PE-81731 PE-53139 PE-49817 PE-87300 PE-109807 PE-111310 PE-106523 PE-111650 PE-68592 PE-71197 PE-102297 PE-103956 PE-105105 PE-111584 PE-105348 PE-111451 PE-110851 PE-110799 PE-71779 PE-76073 PE-110918 PE-106241 PE-100442 PE-48095 PE-109800 PE-89298 PE-110076 PE-89303 PE-107574 PE-97792 PE-104615 PE-104759 PE-106491 PE-106554 PE-89301 PE-104387 PE-103342 PE-102627 JEB-111727 JEB-111773 JEB-111730 JEB-111095 JEB-110914 JEB-111708 JEB-111802 JEB-110851 JEB-56869 JEB-64050 JEB-110930 JEB-108551 JEB-111310 JEB-105279 JEB-105280 JEB-105282 JEB-105285 JEB-71197 JEB-111656 JEB-110885 JEB-109807 JEB-109808 JEB-103956 HEL-44924 HEL-109689 HEL-109831 HEL-111752 HEL-111714 HEL-103956 HEL-110918 HEL-87300 HEL-109322 HEL-76073 HEL-111790 HEL-103905 HEL-105274 HEL-105340 HEL-105103 HEL-105272 HEL-105350 HEL-105118 HEL-105273 HEL-105102 HEL-105343 HEL-111451 HEL-110277 HEL-109800 Total = 90 Par ailleurs, si la liste est trop longue, elle sera tronquée dans la fenêtre Exécution (Immediate window). Dans ce cas, au lieu d'utiliser Debug.Print, il faudrait imprimer la chaîne ListeTrouvés et le nombre Total dans un document Word. |
#6
|
|||
|
|||
Oui, la malédiction de la tour de Babel. HA HA. Ça a marché! Merci beaucoup. Encore une demande, si cela ne vous dérange pas. Existe-t-il un moyen d'extraire les résultats dans un fichier Excel? Sinon, peut-être un fichier texte ou même une boîte de dialogue dans Word. Actuellement, je ne vois les résultats que si je l'exécute avec la macro ouverte. Je veux pouvoir exécuter cette macro à partir d'une touche de raccourci et produire les résultats en externe.
|
#7
|
|||
|
|||
Cela ne me dérange pas, ça m'occupe en ces temps de confinement.
Voici une nouvelle version complétée : la sortie se fait dans un fichier texte qui s'enregistre dans la racine du disque C. Bien entendu, la terrifiante malédiction a été exorcisée, du moins je l'espère. Pour une sortie sur Excel, c'est bien sûr faisable, mais je n'en sais pas assez. 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 texte Dim SortieFichier As Integer 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 .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) 'Sortie des résultats dans le fichier texte SortieFichier = FreeFile Open "c:\SortieFichier.txt" For Output As #SortieFichier Print #SortieFichier, ListeTrouvés Close #SortieFichier End Sub Last edited by jpl; 12-04-2020 at 08:02 AM. Reason: Corrections mineures |
#8
|
|||
|
|||
You are most gracious. Since this might be used by others, is there a way to open a Save As dialog box to prompt users to save to a directory of their choice? I ran into a permissions error attempting to save to my root C: drive.
...or just create the file and open it immediately. |
#9
|
|||
|
|||
I can't read French but while I see the methods used by jpl clearly work, here is an alternative using a collection to reject the duplicates. The output file path is defined in the calling macro and created (or recreated) in the called macro (it doesn't have to be preexisting.)
Code:
Sub ScratchMacro() Dim Prefixes As Variant, Prefix As Variant Dim oColUnique As New Collection Dim arrUnique() As String Dim lngIndex As Long Dim oRng As Range Dim strOut As String 'What do we want to find Prefixes = Array("PE-", "JEB-", "HEL-") For Each Prefix In Prefixes Set oRng = ActiveDocument.Range With oRng.Find .ClearFormatting .MatchWildcards = True .Text = Prefix & "[0-9]{1,}" .Forward = True While .Execute On Error Resume Next oColUnique.Add Trim(oRng.Text), Trim(oRng.Text) If Err.Number = 0 Then 'Any duplicate will error (i.e., and error number <> 0). This code runs for unique results only. ReDim Preserve arrUnique(lngIndex) arrUnique(lngIndex) = oRng.Text lngIndex = lngIndex + 1 End If oRng.Collapse wdCollapseEnd Wend End With Next Prefix 'Sort results WordBasic.SortArray arrUnique 'Form a string from the results strOut = Join(arrUnique, vbCr) & vbCr & "Total - " & UBound(arrUnique) + 1 'Msgbox strOut WriteToTextFile "D:\Collection Results.txt", strOut lbl_Exit: Exit Sub End Sub Sub WriteToTextFile(strPath As String, strContent As String) Dim oFSO As Object, oFile As Object Dim lngIndex As Long Set oFSO = CreateObject("Scripting.FileSystemObject") Set oFile = oFSO.CreateTextFile(strPath) oFile.Close lngIndex = FreeFile Open strPath For Output As #lngIndex Print #lngIndex, strContent Close #lngIndex lbl_Exit: Set oFSO = Nothing: Set oFile = Nothing Exit Sub End Sub |
#10
|
|||
|
|||
Thank you, Greg. Since this can be used by others, is there a way to open a Save As dialog box to prompt users to save to a directory of their choice? encountered a permissions error while trying to save to my root C: drive.
... or just create the file and open it immediately. Saving/opening in an Excel file would be ideal. |
#11
|
|||
|
|||
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 |
#12
|
|||
|
|||
This is great! Thank you, jpl.
|
#13
|
|||
|
|||
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 Last edited by jpl; 12-04-2020 at 12:22 PM. Reason: correction de la malédiction |
#14
|
|||
|
|||
Thank you jpl for your compliment.
robnun, to write to Excel, call a different procedure: Code:
Option Explicit Sub ScratchMacro() Dim Prefixes As Variant, Prefix As Variant Dim oColUnique As New Collection Dim arrUnique() As String Dim lngIndex As Long Dim oRng As Range Dim strOut As String 'What do we want to find Prefixes = Array("PE-", "JEB-", "HEL-") For Each Prefix In Prefixes Set oRng = ActiveDocument.Range With oRng.Find .ClearFormatting .MatchWildcards = True .Text = Prefix & "[0-9]{1,}" .Forward = True While .Execute On Error Resume Next oColUnique.Add Trim(oRng.Text), Trim(oRng.Text) If Err.Number = 0 Then 'Any duplicate will error (i.e., and error number <> 0). This code runs for unique results only. ReDim Preserve arrUnique(lngIndex) arrUnique(lngIndex) = oRng.Text lngIndex = lngIndex + 1 End If oRng.Collapse wdCollapseEnd Wend End With Next Prefix 'Sort results WordBasic.SortArray arrUnique WriteToExcel arrUnique lbl_Exit: Exit Sub End Sub Sub WriteToExcel(ByRef arrPassed As Variant) Dim oApp As Object, oBook As Object, oSheet As Object Dim lngNextRow As Long If Not IsArray(arrPassed) Then Exit Sub On Error Resume Next Set oApp = GetObject(, "Excel.Application") If Err <> 0 Then Set oApp = CreateObject("Excel.Application") On Error GoTo 0 With oApp .Visible = True Set oBook = .Workbooks.Add End With Set oSheet = oBook.Sheets("Sheet1") lngNextRow = oSheet.Range("A" & oSheet.Rows.Count).End(-4162).Row + 1 oBook.Sheets(1).Range("A" & lngNextRow).Resize(UBound(arrPassed) - LBound(arrPassed) + 1).Value = oApp.Transpose(arrPassed) lbl_Exit: Set oApp = Nothing: Set oBook = Nothing: Set oSheet = Nothing Exit Sub End Sub |
#15
|
|||
|
|||
En reprenant l'idée de Greg Maxey, voici une version où la liste sortie dans le fichier Word est triée :
1. dans l'ordre alphabétique croissant des préfixes (HEL-, JEB-, PE-) 2. et pour chaque préfixe, dans l'ordre croissant des nombres. Code:
Sub Essai() Dim Trouvé As String, ListeTrouvés As String Dim Prefixes As Variant, Prefixe As Variant Dim Total As Long 'Pour la sortie dans un fichier Word Dim Fichier As Document Dim Plage As Range Dim TableauListe As Table 'Construction de la liste 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) 'Sauvegarde de la liste dans un fichier Word Set Fichier = Documents.Add() Set Plage = Fichier.Range Plage.Text = "Liste à sauvegarder :" & vbCrLf 'Impression de la liste ordonnée Plage.Collapse Direction:=wdCollapseEnd Plage.Text = ListeTrouvés Set TableauListe = Plage.ConvertToTable(Separator:="-") TableauListe.Sort FieldNumber:="Colonne 1", SortFieldType:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending, _ FieldNumber2:="Colonne 2", SortFieldType2:=wdSortFieldNumeric, SortOrder2:=wdSortOrderAscending TableauListe.Rows.ConvertToText Separator:="-" 'Impression du total Plage.Collapse Direction:=wdCollapseEnd Plage.Text = "Total = " & CStr(Total) End Sub Last edited by jpl; 12-05-2020 at 11:14 PM. Reason: Simplification du code |
Thread Tools | |
Display Modes | |
|
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 |