Sub ExportData()
Dim StrData As String, StrTmp As String, i As Long
Dim xlApp As Object, xlWkBk As Object
With ActiveDocument.Range
  .InsertBefore vbCr
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "^13[0-9]{1,}. ACA-[0-9]{5}"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found
    StrData = StrData & .Text
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
  Undo 1
End With
' Test whether Excel is already running.
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
'Start Excel if it isn't running
If xlApp Is Nothing Then
  Set xlApp = CreateObject("Excel.Application")
  If xlApp Is Nothing Then
    MsgBox "Can't start Excel.", vbExclamation
    Exit Sub
  End If
End If
On Error GoTo 0
With xlApp
  Set xlWkBk = .Workbooks.Add
  ' Update the workbook.
  With xlWkBk.Worksheets(1)
    For i = 1 To UBound(Split(StrData, vbCr))
      .Cells(i, 1).Value = Split(StrData, vbCr)(i)
    Next
  End With
  ' Tell the user we're done.
  MsgBox "Data extraction finished.", vbOKOnly
  ' Switch to the Excel workbook
  .Visible = True
End With
' Release object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
End Sub