提取Excel表范围并复制到新的Word文档中

Question

I want to copy a excel range into a new word document .Some range that I don't really want to remain here so I hide those certain rows first manually .Then ,I will run my vb program and paste into a new word document automatically .

However ,I copy the range and paste into the new word document in a picture format . I want to paste into a word table format .But please remained that ,the word table format should best fit with the landscape A4 word format .How to do this ?

Here is my code :

    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

First of all, you need to trigger standard copy but not .CopyPicture method :

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

Next, you can trigger .PasteExcelTable method like this:

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

Please make some tests with both WordFormattin and RTF parameters. Depending on True or False you can have slightly different results. Proposed solution will try to paste in the way to fit current page layout. But if source table is too wide or too high it could not work without additional adjustments.

Answer 2

Please give this a try...

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