Excel to Word table copy paste

henrik2h

Board Regular
Joined
Aug 25, 2008
Messages
124
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.

VBA Code:
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

Well-known Member
Joined
Nov 1, 2008
Messages
3,524
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.

VBA Code:
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
 

Forum statistics

Threads
1,078,492
Messages
5,340,686
Members
399,389
Latest member
JayNExcel

Some videos you may like

This Week's Hot Topics

  • Problem with Radio Button's format control
    I am creating an employee evaluation template (a sample is below) Column A is the category Column B, C D, E and F will be ratings (unacceptable...
  • Last Display on userform to a Listbox
    [CODE=vba] lstdisplay.ColumnCount = 15 lstdisplay.RowSource = "A1:O600000" [/CODE] So when i do this it Displays everything on the sheet i am...
  • Rename and move files to a new location
    Dear all, I have an excel file with the following information. The actual file name is at column A but i want to rename it using the following...
  • Help with True/False Formula
    Hello! Am stumped how to fix this formula, in which my result returns 'True', but it should return False. =IF(AG2=True...
  • Clear extra characters from a provided range of cells
    Dear All, I have following code which gives me desired output to remove extra characters from a provided range. But it takes too much time when...
  • Help with Current and highest streaks
    Hi there, I've just joined the forum and this is my first post. I've already spent quite a bit of time searching the net and this forum for a...
Top