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

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