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

相关文章推荐

难过的盒饭 · recyclerview 横滑 item ...· 10 月前 ·

光明磊落的镜子 · 前端项目下载文件方案全解 - 知乎· 2 年前 ·

礼貌的机器人 · dpdk Segmentation ...· 2 年前 ·

憨厚的乌冬面 · linux 查看进程栈大小 - ...· 2 年前 ·

活泼的匕首 · Spring Security 4.x ...· 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用户