Sub List()
  Dim oDoc As Document, oTarget As Document
  Dim oRng As Range, oPara As Range
  Dim str As String, arr() As String, i As Integer
  
  Set oDoc = ActiveDocument
  Set oRng = oDoc.Range
  With oRng.Find
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = False
    .Text = "#"
    Do While .Execute = True
      Set oPara = oRng.Paragraphs(1).Range
      Debug.Print oPara.Text
      arr = Split(oPara.Text, "#")
      For i = 1 To UBound(arr)
        str = str & arr(0) & vbCr
      Next i
      oRng.Start = oPara.End
    Loop
  End With
  If str <> "" Then
    Set oTarget = Documents.Add
    oTarget.Range.Text = str    'put list into new unsaved doc
  End If
End Sub