Excel to Word table copy paste

[henrik2h]

I know, maybe this is not the right forum but it is the one I usually use...

I got it working pasting Excel range to Word as a picture. I now also want to paste part of an Excel table to word and merge the tables. The table can change in size and might also break the page so i can't use the same "picture" method. Maybe I made a mistake and tried to attack the problem from Word, should maybe have stayed in Excel and pushed it to Word?

I have a table in Excel. It is difficult formatting the table headings the way I want so I have a one row table in Word with the headings, below I want to have the data. If I copy the Databodyrange+Totalsrange in Excel and place the cursor just below the one row table in Word and paste, the two tables merge. This is what I want to accomplish.

The below code (Word VBA) is not working, it is stopping at the Databodyrange selection, any idea why? I do not know if the "paste code" work yet, that is my next aim. I have not found a way to select both the Databodyrange and the Totalsrange.

Any thoughts welcome.

Sub Import_data()

    Dim wDoc As Document, wb As Workbook
    Dim wApp As Application
    Dim fd As Office.FileDialog
    Dim FileSelect As String
    Dim tbl_rng As Excel.Range
    Dim tblS_rng As Excel.Range
    Dim WordTable As Word.Table
    
    Application.ScreenUpdating = False
    
    'Set target word document
    Set wApp = GetObject(, "Word.Application")
    Set wDoc = wApp.ActiveDocument

    'Open the source workbook

    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    fd.AllowMultiSelect = False
    fd.Title = "Please select the Excel file."
    fd.Show
    FileSelect = fd.SelectedItems(1)
    
    Workbooks.Open (FileSelect)
    Set wb = ActiveWorkbook


    'Copy ranges from Excel to Word
    
    ''wb.Sheets("Driftbudget").Range("Driftbudget").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    ''wApp.Visible = True
    ''wDoc.Bookmarks("BM_Driftbudget").Select
    ''Selection.Paste
            
    ''wb.Sheets("Anskaffning").Range("Anskaffning").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    ''wApp.Visible = True
    ''wDoc.Bookmarks("BM_Anskaffning").Select
    ''Selection.Paste
    
    ''wb.Sheets("Ek.prognos").Range("Ek_prognos").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    ''wApp.Visible = True
    ''wDoc.Bookmarks("BM_Ekonomiskprognos").Select
    ''Selection.Paste
    
    ''wb.Sheets("Ek.prognos").Range("Kanslighet").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    ''wApp.Visible = True
    ''wDoc.Bookmarks("BM_Kanslighet").Select
    ''Selection.Paste
        
    'Copy table from Excel to Word
    
    wb.Worksheets("Lgh").ListObjects("tbLghlista_Output").DataBodyRange.Select

    
    'Copy Excel Table Range
    Selection.Copy

    'Paste Table into MS Word
    wDoc.Bookmarks("BM_Lghlista1").Select
    Selection.Paragraphs(1).Range.PasteExcelTable _
    LinkedToExcel:=False, _
    WordFormatting:=False, _
    RTF:=False
    
    'Repeat for Totals row
    wb.Worksheets("Lgh").ListObjects("tbLghlista_Output").TotalsRowRange.Select
    Selection.Copy
    wDoc.Bookmarks("BM_Lghlista2").Select
    Selection.Paragraphs(1).Range.PasteExcelTable _
    LinkedToExcel:=False, _
    WordFormatting:=False, _
    RTF:=False
    
    
    
    'Autofit Table so it fits inside Word Document
    Set WordTable = wDoc.Tables(1)
    WordTable.AutoFitBehavior (wdAutoFitContent)
 
    wb.Close savechanges:=False
        
    Application.ScreenUpdating = True

    
    
End Sub

 

[sijpie]

For some reason I never get Sheetx.Listobjects("TableName") to work properly. So I either use the direct method or the loop method, as shown below, to get to the table.

I also show how to combine the two ranges in one range to be copied. Be carefull with the comma! this is a text comma not a separator comma.

Sub t()
    Dim loL As ListObject
    Dim r As Range
    
    
    Set loL = ActiveSheet.ListObjects(1)
    Set r = Range(loL.DataBodyRange.Address & "," & loL.TotalsRowRange.Address)
    r.Copy
'    Do your paste in word
End Sub


Sub tt()
    Dim loL As ListObject
    Dim r As Range
    
    
    For Each loL In ActiveSheet.ListObjects
        If loL.Name = "Table1" Then Exit For
    Next loL
    
    If loL Is Nothing Then Exit Sub 'table not found
    
    Set r = Range(loL.DataBodyRange.Address & "," & loL.TotalsRowRange.Address)
    r.Copy
'    Do your paste in word

End Sub

[/code