Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 12-04-2020, 12:56 PM
gmaxey gmaxey is offline Count Unique Instances of Multiple Strings Using Wildcards Windows 10 Count Unique Instances of Multiple Strings Using Wildcards Office 2016
Expert
 
Join Date: May 2010
Location: Brasstown, NC
Posts: 1,617
gmaxey is just really nicegmaxey is just really nicegmaxey is just really nicegmaxey is just really nicegmaxey is just really nice
Default

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

__________________
Greg Maxey
Please visit my web site at http://www.gregmaxey.com/
Reply With Quote
  #2  
Old 12-05-2020, 08:50 AM
jpl jpl is offline Count Unique Instances of Multiple Strings Using Wildcards Windows 7 64bit Count Unique Instances of Multiple Strings Using Wildcards Office 2010 32bit
Advanced Beginner
 
Join Date: Jan 2016
Location: France
Posts: 33
jpl is on a distinguished road
Default

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
Reply With Quote
Reply



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 Instances of Multiple Strings Using Wildcards Count unique values that match 2 or more criteria caeiro01 Excel 1 10-25-2015 02:34 AM
Count Unique Instances of Multiple Strings Using Wildcards Display unique values and count the number of child items vthomeschoolmom Excel 2 07-25-2013 06:17 AM

Other Forums: Access Forums

All times are GMT -7. The time now is 06:52 PM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2025, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2025 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft