Sub CopyTabletoWord()
' Keyboard Shortcut: Ctrl+Shift+T

'  This macro copies all cells from the current worksheet into a
'  table in Word.  The table is saved as a Windows Metafile graphic,
'  centered on the page.  A page break is entered in the Word
'  document immediately following the table.

Dim LastRow, LastCol As Integer
Dim r As Range
Dim msg As String

Call LastCellsWithData(LastRow, LastCol)
msg = "Rows/Columns=" & CStr(LastRow) & "/" & CStr(LastCol)
' MsgBox msg
Set r = Range("a1").Resize(LastRow, LastCol)
r.CopyPicture Appearance:=xlScreen, Format:=xlPicture

On Error Resume Next
' Reference existing instance of Word
Set WDApp = GetObject(, "Word.Application")
If WDApp Is Nothing Then
' Word is not running, create new instance
  Set WDApp = CreateObject("Word.Application")
  WDApp.Visible = True
End If
On Error GoTo 0
If WDApp.Documents.Count = 0 Then
' Create a new document
   Set WDDoc = WDApp.Documents.Add
' Reference active document
   Set WDDoc = WDApp.ActiveDocument
End If

' Paste the range

WDApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
        Placement:=wdInLine, DisplayAsIcon:=False

' Center the table on this page:
WDApp.Selection.PageSetup.VerticalAlignment = wdAlignVerticalCenter
' Insert a page break
WDApp.Selection.InsertBreak Type:=wdPageBreak
' Clean up
Set WDDoc = Nothing
Set WDApp = Nothing
End Sub

Public Sub LastCellsWithData(LastRowWithData, LastColWithData)
Dim Row, Col As Integer
Dim ExcelLastCell As Variant

' ExcelLastCell is what Excel thinks is the last cell
Set ExcelLastCell = ActiveSheet.Cells.SpecialCells(xlLastCell)

' Determine the last row with data in it (must also copy above para for this to work)
LastRowWithData = ExcelLastCell.Row
Row = ExcelLastCell.Row
Do While Application.CountA(ActiveSheet.Rows(Row)) = 0 And Row <> 1
    Row = Row - 1
LastRowWithData = Row ' Row number

' Determine the last column with data in it (must also copy the top para for this to work)
LastColWithData = ExcelLastCell.Column
Col = ExcelLastCell.Column
Do While Application.CountA(ActiveSheet.Columns(Col)) = 0 And Col <> 1
    Col = Col - 1
LastColWithData = Col ' Column number
End Sub