提取excel表范围并复制到新的word文档中

Question

我想将一个excel范围复制到一个新的word文档中。我不想留在这里的一些范围，所以我先手动隐藏这些行。然后，我将运行我的vb程序并粘贴到一个新的word文档自动。

但是，我会复制范围并粘贴到图片格式的新word文档中。我想粘贴到一个单词表格式。但请保持这一点，单词表格式最适合A4横向格式。如何做到这一点？

这是我的代码：

    Sub gen()


    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("17-18")             ' Change e.g. sheet9.Name
    'Optimize Code
    Application.ScreenUpdating = False
    Application.EnableEvents = False

'Value1 = Me.TextBox1.Value
'Value2 = Me.TextBox2.Value
    'ws.Rows("84:89").EntireRow.Hidden = True 'ADJUST AS APPROPRIATE

    'Copy Range from Excel
    'Set tbl0 = ws.RANGE("A78:I83")
    'Set Tbl = ws.RANGE(Value1, Value2)
    Set Tbl = ws.RANGE(Selection.Address(ReferenceStyle:=xlA1, _
                           RowAbsolute:=False, ColumnAbsolute:=False))


    ' 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

ws.Rows.EntireRow.Hidden = False
End Sub

Answer 1

首先，您需要触发标准副本，而不是.CopyPicture method：

'Tbl.CopyPicture Appearance:=xlScreen, Format:=xlPicture 'this line ...
Tbl.Copy '...replace with this line

接下来，您可以像这样触发.PasteExcelTable method：

'wordApp.Selection.Paste 'instead of this line...
'...try this one...
wordApp.Selection.PasteExcelTable LinkedToExcel:=False, _
                            WordFormatting:=True, _
                            RTF:=True

请使用WordFormattin和RTF参数进行一些测试。根据{{​​1}}，您可能会略有不同的结果。建议的解决方案将尝试粘贴以适应当前页面布局的方式。但是如果源表太宽或太高，如果没有额外的调整就无法工作。

Answer 2

请试一试......

wordApp.Visible = True
wordApp.Activate

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

'Copy the table
tbl.Range.Copy

'Paste the table into the document as a table
myDoc.Range.PasteExcelTable False, True, False
myDoc.Range.InsertParagraphAfter
myDoc.PageSetup.Orientation = 1