Something along these lines works with your sample doc
Code:
Sub RangeToCSV()
Dim aRng As Range, aNewDoc As Document, sPath As String
Set aRng = ActiveDocument.Tables(1).Range
sPath = ActiveDocument.Path & "\"
aRng.Start = ActiveDocument.Tables(1).Rows(4).Range.Start
Set aNewDoc = Documents.Add
aNewDoc.Range.FormattedText = aRng.FormattedText
aNewDoc.Tables(1).Columns(1).Delete
aNewDoc.Tables(1).ConvertToText Separator:=","
aNewDoc.Paragraphs.Last.Range.Delete
aNewDoc.SaveAs2 FileName:=sPath & "Test.csv", FileFormat:=wdFormatUnicodeText
MsgBox aNewDoc.FullName, , "File Created"
aNewDoc.Close SaveChanges:=False
End Sub