将多个表从选定的Excel范围复制到彼此下面的Word开发者社区

相关文章推荐

爱健身的打火机 · 数据库时间带t和z什么意思 • ...· 7 月前 ·

才高八斗的冰棍 · 高雄市召會 Church in Kaohsiung· 7 月前 ·

慈祥的黄豆 · linux 查看端口监听时间-掘金· 2 年前 ·

强悍的牛肉面 · MySql workbench is ...· 2 年前 ·

灰常酷的显示器 · 湖南大学：电气晋级A类，或新增电气领域“国重 ...· 2 年前 ·

Sub CopyTableToWord()
Selection.Copy
Dim WordApp As Object
Set WordApp = GetObject(, "Word.Application")
WordApp.Visible = True
Dim WordDoc As Object
Set WordDoc = WordApp.Documents("Test.docx")
' cursor position
WordApp.Selection.Range.Characters.Last.InsertParagraphAfter
WordApp.Selection.MoveDown 'Unit:=wdparagraph, Count:=1, Extend:=wdMove
With WordApp.Selection
  .Range.PasteExcelTable False, False, False
  With .Range.Tables(1)
    .Range.ParagraphFormat.SpaceBefore = 0
    .Range.ParagraphFormat.SpaceAfter = 0
    .AutoFitBehavior 2 'wdAutoFitWindow
    .Range.Select
  End With
    ' move out of the table, then add space after it 
    ' to move the Word cursor to the new position
    ' of the next table to be pasted
    .Collapse wdCollapseEnd
    .Range.InsertParagraphAfter
    .MoveDown 'Unit:=wdParagraph, Count:=1, Extend:=wdMove
End With
End Sub

Sub PasteAndFormatTableInWord()
Application.ScreenUpdating = False
Dim wdApp As Word.Application, wdDoc As Word.Document
Const StrDocNm As String = "Test.docx"
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then Set wdApp = CreateObject("Word.Application")
On Error GoTo 0
With wdApp
  'Check if the document is open.
  For Each wdDoc In .Documents
    If wdDoc.Name = StrDocNm Then Exit For
  If wdDoc Is Nothing Then
    MsgBox "Your '" & StrDocNm & "' document isn't open." & vbCr & _
      "Please open the document and select the insertion point.", vbExclamation: Exit Sub
  End If
  wdDoc.Activate
  With .Selection
    .Collapse 1 'wdCollapseStart
    With .Range
      .PasteAndFormat 16 'wdFormatOriginalFormatting
      With .Tables(1)
        .AutoFitBehavior 2 'wdAutoFitWindow
        .Cell(1, 1).PreferredWidthType = 3 'wdPreferredWidthPoints
        .Cell(1, 1).PreferredWidth = 75
        .Range.Characters.Last.Next.InsertBefore vbCrLf
      End With
      .Start = .Tables(1).Range.End + 1
      .Collapse 0 'wdCollapseEnd
      .Select

问 将多个表从选定的Excel范围复制到彼此下面的Word

回答 1

Stack Overflow用户