如何在excel中用vba代码添加word表格?

amesman

在excel中用vba代码添加word表格,写了一些代码,怎样都实现不了,但这些代码放在word中就能实现.
不知为何,请各位高手帮忙看看,具体的情况见附件.谢谢

Private Sub CommandButton1_Click()
      On Error Resume Next
    Dim WordAPP As Object, myWord As Object   
    Dim Fullname As String   
    Fullname = ThisWorkbook.Path & "\新表格.doc"  
    Set WordAPP = CreateObject("Word.Application")
    Set myWord = WordAPP.documents.Open(ThisWorkbook.Path & "\表格.doc")   
    WordAPP.Visible = False
      '============================追加表格==================================  
     myWord.Activate
     myWord.tables(2).Rows.Last.Select '从最后一行开始添加表格
     Selection.InsertRowsBelow 10
     '============================追加表格==================================
      With myWord
         With .tables(1)                                    
              .Cell(1, 2).Range = Date
         End With
       End With
       myWord.SaveAs Filename:=Fullname
   myWord.Close        
   Set myWord = Nothing
   Set WordAPP = Nothing
End Sub

amesman

沉得太快了,自己项一下,

盼版主......

amesman

晕了,沉得太快了!
只有自己顶啊!

守柔

详见Word版，表2中的“序号”可分成二行更妙！
Private Sub CommandButton1_Click()
    Dim wdDoc As Object
    Dim wdTable As Object
    Dim wdRow As Object
    Dim strFullname As String
    strFullname = ThisWorkbook.Path & "\表格.doc"
    If Len(Dir(strFullname, vbDirectory)) = 0 Then
        MsgBox "Excel未找到" & strFullname, vbExclamation
        Exit Sub
    End If
    Set wdDoc = GetObject(strFullname)
    With wdDoc
'''        wdDoc.Application.Visible = True可用于调试
        '============================追加表格==================================
        Set wdTable = .Tables(1)
        wdTable.Cell(1, 2).Range = Date
        Set wdTable = .Tables(2)
        Set wdRow = wdTable.Rows.Last
        wdRow.Select
        .ActiveWindow.Selection.InsertRowsBelow 10
        strFullname = Replace(strFullname, "\表格.doc", "\新表格.doc")
        .SaveAs Filename:=strFullname
        .Close
        Set wdDoc = Nothing
    End With
End Sub