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