Sub word_101025_1812()
Dim j1, j2, s1, s2
s1 = Word.ActiveDocument.FullName
j1 = InStr(s1, ".doc")
s2 = Mid(s1,  1 , j1 -  1 )
j2 = Word.ActiveDocument.Tables.Count
j1 =  0 
Do While j1 < j2
j1 = j1 +  1 
Word.ActiveDocument.Tables(j1).Select
  Selection.Copy
    Documents.Add Template:="Normal", NewTemplate:=False, DocumentType:= 0 
    Selection.PasteAndFormat (wdPasteDefault)
    ActiveDocument.SaveAs FileName:=s2 & "_" &  1000  + j1 & ".doc", _
        FileFormat:=wdFormatDocument, _
        LockComments:=False, Password:="", _
        AddToRecentFiles:=False, WritePassword:="", _
        ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
        SaveNativePictureFormat:=False, _
        SaveFormsData:=False, SaveAsAOCELetter:=False
    ActiveWindow.Close
    Loop
End Sub