Word to Excel (part 2)

In a past post I dealed with the needing of moving Word to Excel. Recently I needed to get all the tables from a bunch of Word documents inside Excel. The thing was that the Copy-PasteSpecial Format:=”Text” did not behaved as expected, as it did not paste as text but as an image. Uhm, we start to get into trouble. To get things worse, then I found that the paste operation was getting itself in problems when they mess with the screenupdating or the calculation… Excel getting into “Busy state”, so I set a “wait until Complete state” loop to solve this point. And then I realised the word tables, that came from a PDF that also came from a Word document had an caotic structure because the “translation” operations. Buf… to much to deal with (after we can get the table stuff). Here is the code that takes the tables from Word to Excel (as they come). Handy to use whenever we need Word To Excel data interchange.
Public Sub read_word_document()
    Dim DOC_PATH As String: DOC_PATH = ThisWorkbook.Path & "\"
    Dim strFile As String
    Dim oXlApp As Excel.Application
    Dim oXlWbk As Excel.Workbook
    Dim oXlWbk0 As Excel.Workbook
    Dim oXlWsh As Excel.Worksheet
    Dim oXlWsh0 As Excel.Worksheet
    Dim oXlRng As Excel.Range
    Dim oXlTRow As Excel.Range
    Dim oXlTCol As Excel.Range
    Dim oXlCell As Excel.Range
    Dim oWdApp As Word.Application
    Dim oWdDoc As Word.Document
    Dim oWdTab As Word.Table
    Dim oWdTRow As Word.Row
    Dim oWdTCol As Word.Column
    Dim oWdCell As Word.Cell
    Dim lgTable As Long
    Dim bGetData As Boolean
    'Dim bSplitData As Boolean
    Dim lgR As Long
    Dim lgC As Long
    Dim strText As String
    Dim aData() As String
    Dim lgData As Long
'    On Error GoTo ErrHandler
    Set oWdApp = GetObject(, "Word.Application")
    'Set oWdApp = CreateObject("Word.Application")
    'oWdApp.Visible = False
    Do While oWdApp.Documents.Count > 0
        oWdApp.ActiveDocument.Close SaveChanges:=False
    Set oXlApp = GetObject(, "Excel.Application")
    'Set oXlApp = CreateObject("Excel.Application")
    'oXlApp.Visible = False
    Set oXlWbk0 = oXlApp.ActiveWorkbook
    'lgR = 0
    strFile = VBA.Dir(DOC_PATH & "*.doc*")
    Do Until strFile = vbNullString
        Set oWdDoc = oWdApp.Documents.Open(Filename:=DOC_PATH & strFile, ReadOnly:=True)

        If oWdDoc.Tables.Count > 0 Then
            Set oXlWbk = oXlApp.Workbooks.Add() '.Open(fileName:=DOC_PATH & strFile, ReadOnly:=False)
            oXlWbk.SaveAs Filename:=DOC_PATH & VBA.Replace(strFile, ".doc", ".xls")
            lgR = 0
            Set oXlWsh0 = oXlWbk0.Sheets.Add
            oXlWsh0.Name = "#" & strFile
            Set oXlRng = oXlWsh0.Range("A1")
            lgTable = 0 ' resume table
            For Each oWdTab In oWdDoc.Tables

'                If vbNo = MsgBox("table " & lgTable & ", resume?", vbYesNo) Then Stop
'                On Error Resume Next
'                For Each oWdTRow In oWdTab.Rows
'                    If Err.Number = 5991 Then GoTo ExitTable
'                    If bGetData Then ' copy this data
'                        lgR = lgR + 1
'                        lgC = 0
'                        For Each oWdCell In oWdTRow.Cells
'                            lgC = lgC + 1
'                            If Not VBA.Trim$(oWdCell.Range.text) Like vbNullString Then
'                                oXlWsh.Cells(lgR, lgC).Value = oWdCell.Range.text
'                            End If
'                        Next oWdCell
'                    End If
'                Next oWdTRow
'                On Error GoTo 0
                'bSplitData = False
                lgTable = lgTable + 1
                Set oXlWsh = oXlWbk.Sheets.Add
                oXlWsh.Name = "H_" & lgTable
                Set oXlRng = oXlWsh.Range("A1")
                ' Copy table to Excel, then depurate
                On Error GoTo ErrWait
                On Error GoTo 0
                'oXlRng.Parent.PasteSpecial Format:="Text", link:=False, DisplayAsIcon:=False
                Set oXlRng = oXlRng.Resize(oWdTab.Rows.Count, oWdTab.Columns.Count)
                With oXlRng
                    With .Cells
                        .MergeCells = False
                        .WrapText = False
                        .VerticalAlignment = xlBottom
                        .Orientation = 0
                        .AddIndent = False
                        .IndentLevel = -1
                        .ShrinkToFit = False
                        .ReadingOrder = xlContext
                        '.columnWidth = 14
                        '.RowHeight = 14
                        .Font.Size = 10
                        .Font.Name = "Calibri"
                    End With
                    For Each oXlTRow In oXlRng.Rows
                        'bGetData = False
                        'For Each oXlCell In oXlTRow.Cells
                        '    If VBA.UCase$(oXlCell.Value) Like "*" Then
                        '        bGetData = True
                        '        Exit For
                        '    End If
                        'Next oXlCell
                        If bGetData Then ' copy this row
                            'bSplitData = True
                            lgR = lgR + 1
                            lgC = 0
                            For Each oXlCell In oXlTRow.Cells
                                'If Not IsEmpty(oXlCell.Value) Then
                                If Not VBA.Trim$(oXlCell.Value) Like vbNullString Then
                                    lgC = lgC + 1
                                    oXlWsh0.Cells(lgR, lgC).Value = oXlCell.Value
                                End If
                            Next oXlCell
                        End If
                    Next oXlTRow
                End With
                'If bSplitData Then lgR = lgR + 3
                Set oXlRng = oXlRng.Offset(oWdTab.Rows.Count + 2, 0)
            Next oWdTab
        End If
        ' Delete all temp worksheets
        'oXlApp.DisplayAlerts = False
        'For Each oXlWsh In oXlWbk.Worksheets
        '    If oXlWsh.Name Like "H*" Then
        '        oXlWsh.Delete
        '    End If
        'Next oXlWsh
        'oXlApp.DisplayAlerts = True

        oWdDoc.Close SaveChanges:=False
        oXlWbk.Close SaveChanges:=False
        strFile = VBA.Dir
'    oWdApp.Quit
    GoTo done
    Application.Wait ((Now + TimeValue("0:00:02")))

    On Error Resume Next
    Debug.Print Err.Description
    On Error GoTo 0

    ' Move all worksheets that has "#" to new file
    Dim aArray As Variant
    lgData = -1
    Erase aData()
    For Each oXlWsh0 In oXlWbk0.Worksheets
        If oXlWsh0.Name Like "[#]*" Then
            lgData = lgData + 1
            ReDim Preserve aData(0 To lgData)
            aData(lgData) = oXlWsh0.Name
        End If
    Next oXlWsh0
    aArray = aData()
End Sub

Leave a Reply

Your email address will not be published. Required fields are marked *