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

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

但是，我复制范围并以图片格式粘贴到新的word文档中。我想粘贴到word表格格式中。但是请记住，word表格格式应该最适合横向A4 word格式。如何操作

这是我的密码：

    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

---

首先，您需要触发标准复制，而不是

。CopyPicture方法

：

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

接下来，您可以触发

.PasteExcelTable方法

，如下所示：

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

---

请使用

WordFormattin

和

RTF

参数进行一些测试。根据

正确或错误

的不同，结果可能略有不同。建议的解决方案将尝试以适合当前页面布局的方式粘贴。但是，如果源表太宽或太高，如果没有额外的调整，它将无法工作。

请尝试一下

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

---

在Word中录制宏，执行适当的粘贴方法。查看记录的代码。可能的解决方案：通过

Excel

宏创建

Word

表格，将

Tbl

值放入数组，在创建的

Word

表格中分配它们。