新的后果

Question

我在excel文件中有两个范围。（A79-I84）＆amp; （A90-I92）

我现在使用Excel.RANGE.copy.复制两个表并粘贴到word文件。

但是，这两个范围变成了两个独立的表，原始的excel表格式无法继承到新的word文件。而且，单词report中的一些单元格将以两行显示。

总之，单词报告的格式会非常混乱。如何将两个表集成到一个具有良好表格格式或对齐的表中？

新表将生成如下：（红笔=问题）

我的代码：

 Sub ExcelRangeToWord()


Dim tbl0 As Excel.RANGE
Dim tbl As Excel.RANGE
Dim tbl2 As Excel.RANGE

Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table

'Optimize Code
  Application.ScreenUpdating = False
  Application.EnableEvents = False

'Copy Range from Excel
  'Set tbl0 = ThisWorkbook.Worksheets(sheet9.Name).RANGE("A78:I83")
  Set tbl = ThisWorkbook.Worksheets(sheet9.Name).RANGE("A78:I83")
  Set tbl2 = ThisWorkbook.Worksheets(sheet9.Name).RANGE("A90:I92")

'Create an Instance of MS Word
  On Error Resume Next

    'Is MS Word already opened?
      Set WordApp = GetObject(Class:="Word.Application")

    'Clear the error between errors
      Err.Clear

    'If MS Word is not already open then open MS Word
      If WordApp Is Nothing Then Set WordApp = CreateObject(Class:="Word.Application")

    'Handle if the Word Application is not found
      If Err.Number = 429 Then
        MsgBox "Microsoft Word could not be found, aborting."
        GoTo EndRoutine
      End If

  On Error GoTo 0

'Make MS Word Visible and Active
  WordApp.Visible = True
  WordApp.Activate

'Create a New Document
  Set myDoc = WordApp.Documents.Add



'Trigger copy separately for each table + paste for each table

    tbl.Copy ' paste range1
    myDoc.Paragraphs(1).RANGE.PasteExcelTable _
        LinkedToExcel:=False, _
        WordFormatting:=True, _
        RTF:=False

'before that...
'...go to end of doc and add new paragraph
    myDoc.Bookmarks("\EndOfDoc").RANGE.InsertParagraphAfter
    tbl2.Copy 'paste range2

'Paste Table into MS Word last paragraph
    myDoc.Paragraphs(myDoc.Paragraphs.Count).RANGE.PasteExcelTable _
        LinkedToExcel:=False, _
        WordFormatting:=True, _
        RTF:=False



'Autofit Table so it fits inside Word Document
  Set WordTable = myDoc.Tables(1)
  WordTable.AutoFitBehavior (wdAutoFitWindow)

EndRoutine:
'Optimize Code
  Application.ScreenUpdating = True
  Application.EnableEvents = True

'Clear The Clipboard
  Application.CutCopyMode = False

End Sub

新的后果

Answer 1

尝试以下方法。只需隐藏中间的行（您不希望看到的行）并将其作为一个范围复制为“A79：I92”并粘贴为图片。信用here（@sneep），用于调整图片大小。请注意，这将调整所有图像的大小，但可以调整为仅针对一个。

Option Explicit

Sub ExcelRangeToWord()


    Dim tbl0 As Excel.Range
    Dim Tbl As Excel.Range
    Dim tbl2 As Excel.Range

    Dim wordApp As Word.Application
    Dim myDoc As Word.Document
    Dim WordTable As Word.Table
    Dim wb As Workbook
    Dim ws As Worksheet

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Sheet2")             ' Change e.g. sheet9.Name
    'Optimize Code
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    ws.Rows("84:89").EntireRow.Hidden = True 'ADJUST AS APPROPRIATE

    'Copy Range from Excel
    'Set tbl0 = ws.RANGE("A78:I83")
    Set Tbl = ws.Range("A78:I92")


    ' Set tbl2 = ws.Range("A90:I92")

    'Create an Instance of MS Word
    On Error Resume Next

    'Is MS Word already opened?
    Set wordApp = GetObject(Class:="Word.Application")

    'Clear the error between errors
    Err.Clear

    'If MS Word is not already open then open MS Word
    If wordApp Is Nothing Then Set wordApp = CreateObject(Class:="Word.Application")

    'Handle if the Word Application is not found
    If Err.Number = 429 Then
        MsgBox "Microsoft Word could not be found, aborting."
        GoTo EndRoutine
    End If

    On Error GoTo 0

    'Make MS Word Visible and Active
    wordApp.Visible = True
    wordApp.Activate

    'Create a New Document
    Set myDoc = wordApp.Documents.Add

    'Trigger copy separately for each table + paste for each table

    Tbl.CopyPicture Appearance:=xlScreen, Format:=xlPicture

    wordApp.Selection.Paste
    wordApp.Selection.TypeParagraph

    wordApp.Selection.PageSetup.Orientation = wdOrientLandscape

    resize_all_images_to_page_width myDoc

EndRoutine:
    'Optimize Code
    Application.ScreenUpdating = True
    Application.EnableEvents = True

    'Clear The Clipboard
    Application.CutCopyMode = False

End Sub


Sub resize_all_images_to_page_width(myDoc As Document)
  'https://blog.qiqitori.com/?p=115
    Dim inline_shape As InlineShape
    Dim percent As Double

    For Each inline_shape In myDoc.InlineShapes
        inline_shape.LockAspectRatio = msoFalse
        inline_shape.ScaleWidth = 100
        inline_shape.ScaleHeight = 100
        percent = myDoc.PageSetup.TextColumns.Width / inline_shape.Width
        inline_shape.ScaleWidth = percent * 100
        inline_shape.ScaleHeight = percent * 100
    Next
End Sub

如何将excel系列集成到一个表中？

新的后果

1 个答案: