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