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