The document contained a mishmash of Excel and Word code. As were are working from Word, the code needs to be in a template (if it is just for you, the normal template will work) and should be something like the following. This will open a new Excel workbook and paste the data with the same cell content as it has in the processed Word table.
Code:
Option Explicit
Sub Process_Word_File()
Dim xlApp As Object
Dim xlBook As Object
Dim wdDoc As Document
Dim wdFileName As Variant
Dim i As Long
wdFileName = BrowseForFile("Select the Word document to process", False)
If wdFileName = "" Then GoTo lbl_Exit
Set wdDoc = Documents.Open(wdFileName)
Delete_Header_first_row
RemoveSectionBreaks
DeleteEmptyParas
wdDoc.Tables(1).Range.Copy
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err Then
Set xlApp = CreateObject("Excel.Application")
End If
On Error GoTo 0
Set xlBook = xlApp.Workbooks.Add
xlApp.Visible = True
xlBook.sheets(1).Range("A1").PasteSpecial ("HTML")
With xlBook.sheets(1).usedrange
.VerticalAlignment = -4160
.HorizontalAlignment = -4131
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = -1
.ShrinkToFit = False
.ReadingOrder = -5002
.MergeCells = False
.Columns.AutoFit
End With
'wdDoc.Close 0
lbl_Exit:
Set xlApp = Nothing
Set xlBook = Nothing
Set wdDoc = Nothing
Exit Sub
End Sub
Sub Delete_Header_first_row()
Dim oTable As Object
For Each oTable In ActiveDocument.Range.Tables
oTable.Cell(1, 1).Select
Selection.MoveRight Unit:=1, Count:=2, Extend:=1
Selection.Rows.Delete
Next oTable
lbl_Exit:
Set oTable = Nothing
Exit Sub
End Sub
Sub RemoveSectionBreaks()
Dim oRng As Object
Set oRng = ActiveDocument.Range
With oRng.Find
.Text = "^b" ' section break
.Wrap = 0
While .Execute
oRng.Delete
Wend
End With
lbl_Exit:
Set oRng = Nothing
Exit Sub
End Sub
Sub DeleteEmptyParas()
Dim oPara As Object
For Each oPara In ActiveDocument.Range.Paragraphs
If Not oPara.Range.Information(12) Then
If Len(oPara.Range) = 1 Then oPara.Range.Delete
End If
Next oPara
lbl_Exit:
Set oPara = Nothing
Exit Sub
End Sub
Function BrowseForFile(Optional strTitle As String, Optional bExcel As Boolean) As String
'Graham Mayor
'strTitle is the title of the dialog box
'Set bExcel value to True to filter the dialog to show Excel files
'The default is to show Word files
Dim fDialog As FileDialog
On Error GoTo err_Handler
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
.Title = strTitle
.AllowMultiSelect = False
.Filters.Clear
If bExcel Then
.Filters.Add "Excel workbooks", "*.xls,*.xlsx,*.xlsm"
Else
.Filters.Add "Word documents", "*.doc,*.docx,*.docm"
End If
.InitialView = msoFileDialogViewList
If .Show <> -1 Then GoTo err_Handler:
BrowseForFile = fDialog.SelectedItems.Item(1)
End With
lbl_Exit:
Exit Function
err_Handler:
BrowseForFile = vbNullString
Resume lbl_Exit
End Function