Sub List()

    Dim oDoc As Document, oTarget As Document
    Dim oRng As Range, oPara As Range
    Set oDoc = ActiveDocument
    Set oTarget = Documents.Add
    Set oRng = oDoc.Range
    
    Dim str As String, arr() As String, i As Integer
    Set oRng = ActiveDocument.Range
    With oRng.Find
      Do While .Execute(findText:="#")
        arr = Split(oRng.Paragraphs(1).Range.Text, "#")
        For i = 1 To UBound(arr)
          str = str & arr(0) & vbCr
        Next i
       Set oRng = oRng.Paragraphs(1).Range
       oRng.Collapse Direction:=wdCollapseEnd
       oRng.End = ActiveDocument.Range.End
      Loop
    End With
    Debug.Print str
    
    Set oDoc = Nothing
    Set oTarget = Nothing
    Set oRng = Nothing
    Set oPara = Nothing
    
    Dim DateStr, FileStr As String
    DateStr = Format(CStr(Now), "yyyy-mm-dd hh mm")
    FileStr = "List " & DateStr & ".docx"

        ChangeFileOpenDirectory "C:\Users\dopey\Documents\List\"
        ActiveDocument.SaveAs2 FileName:=FileStr, FileFormat:= _
        wdFormatXMLDocument
        ActiveDocument.Close
        Windows("List.docx").Activate

Dim intResponse As Integer
 
intResponse = _
 MsgBox("Do you want to save all documents?", vbYesNo)
 If intResponse = vbYes Then Application.Quit _
 SaveChanges:=wdSaveChanges, OriginalFormat:=wdWordDocument

End Sub