![]() |
|
#1
|
|||
|
|||
![]()
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 |
#2
|
|||
|
|||
![]()
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 | 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 |
![]() |
caeiro01 | Excel | 1 | 10-25-2015 02:34 AM |
![]() |
vthomeschoolmom | Excel | 2 | 07-25-2013 06:17 AM |