Copy to Table from Excel 

Function GetExcelData() As Boolean
  On Error GoTo errHandler1
  Dim objTableRow As IHTMLTableRow
  Dim intExcelRowsCount As Integer
  Dim intExcelColumnsCount As Integer
  Dim intHeaderRows As Integer
  Dim arrGeneral As Variant

  'Excel must be startes so that GetObject works.
  Set objExcel = GetObject(, "Excel.Application")

  'Open the workbood that you want to copy from.
  Set objWorkBook = objExcel.ActiveWorkbook

  'Go to the Worksheet that you want to copy from.
  Set objWorksheet = objExcel.ActiveSheet

  'Check Excel to see if a header row
  'is frozen at top
  If objExcel.ActiveWindow.FreezePanes = True Then
    'Get number of split (header) rows in Excel.
    intHeaderRows = objExcel. _
    ActiveWindow.SplitRow
  End If

  'Number of Excel rows to put in body will be
  'Total rows minus header rows.
  intExcelRowsCount = _
  objWorksheet.UsedRange.rows.Count _
  - intHeaderRows
  intExcelColumnsCount = _
  objWorksheet.UsedRange.Columns.Count

  'Add a table equal to the number of
  'Excel header rows, body rows and columns
  If Not AddTable("Glenfield", _
  intExcelRowsCount + 1, _
  intExcelColumnsCount, _
  intHeaderRows, 0) _
  Then GoTo errHandler1

  'Get the array of all the
  'table indexes with title "Glenfield"
  arrGeneral = _
  GetTableIndexNumbers("Glenfield")

  'Set objTable to the first table
  'with Title Glenfield
  Set objTable = _
  ActiveDocument.all.tags("table"). _
  Item(arrGeneral(1))

  'Process THead first.
  'Loop through all Header rows.
  For i = 0 To objTable.tHead. _
  rows.Length - 1
    'Loop through all the columns
    For j = 0 To objTable.tHead. _
    rows(0).cells.Length - 1
      'Put Excel values into Table.
      objTable.tHead.rows(i). _
      cells(j).innerText = _
      objWorksheet.cells(i + 1, j + 1)
    Next j
  Next i

  'Process Tbodies second.
  For i = 0 To objTable.tBodies.Item(0). _
  rows.Length - 1
    For j = 0 To intExcelColumnsCount - 1
      'Set Expression Web Cell value
      'to Excel value.
      objTable.tBodies.Item(0).rows(i). _
      cells(j).innerText = _
      objWorksheet.cells(i + 1 + _
      intHeaderRows, j + 1).Value
  
      'Merge some of the cells
      'to minimize cell wrapping
      'If the Excel cell is not null.
      If objWorksheet.cells( _
      i + 1 + intHeaderRows, _
      j + 1).Value <> "" Then
        Select Case j
          Case 0
            'Merge columns 1 through 4
            objTable.tBodies.Item(0).rows(i). _
            cells.Item(0).colSpan = "4"
            'Delete new columns 5, 6 and 7.
            objTable.tBodies.Item(0).rows(i). _
            cells.Item(3).outerHTML = ""
            objTable.tBodies.Item(0).rows(i). _
            cells.Item(2).outerHTML = ""
            objTable.tBodies.Item(0).rows(i). _
            cells.Item(1).outerHTML = ""
            'Set j = 3 to force loop to next row.
            j = 3
 
          Case 1
            'Merge columns 2 through 4
            objTable.tBodies.Item(0).rows(i). _
            cells.Item(1).colSpan = "3"
            'Delete new columns 5 and 6.
            objTable.tBodies.Item(0).rows(i). _
            cells.Item(3).outerHTML = ""
            objTable.tBodies.Item(0).rows(i). _
            cells.Item(2).outerHTML = ""
            'Set j = 3 to force loop to next row.
            j = 3

          Case 2
            'Merge columns 3 and 4
            objTable.tBo   dies.Item(0).rows(i). _
            cells.Item(2).colSpan = "2"
            'Delete new column 5.
            objTable.tBodies.Item(0).rows(i). _
            cells.Item(3).outerHTML = ""
            'Set j = 3 to force loop to next row.
            j = 3
        End Select
      End If
    Next j
  Next i

  GetExcelData = True
  Exit Function
errHandler1:
  GetExcelData = False
  MsgBox "GetExcelData has failed.", _
  vbCritical, "Function Failure"

End Function