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 Loop 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 oXlWsh0.Activate Set oXlRng = oXlWsh0.Range("A1") 'oXlWsh0.Cells.ClearContents oXlRng.Select lgTable = 0 ' resume table For Each oWdTab In oWdDoc.Tables DoEvents ' 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 'ExitTable: ' On Error GoTo 0 'bSplitData = False lgTable = lgTable + 1 Set oXlWsh = oXlWbk.Sheets.Add oXlWsh.Name = "H_" & lgTable oXlWsh.Activate Set oXlRng = oXlWsh.Range("A1") oXlRng.Select ' Copy table to Excel, then depurate oWdTab.Select On Error GoTo ErrWait oWdTab.Range.Copy oXlRng.Parent.Paste 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 .UnMerge .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 'Stop ' 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 'Stop oWdDoc.Close SaveChanges:=False oXlWbk.Close SaveChanges:=False strFile = VBA.Dir Loop ' oWdApp.Quit GoTo done ErrWait: 'Stop Application.Wait ((Now + TimeValue("0:00:02"))) Resume ErrClose: On Error Resume Next ErrHandler: Debug.Print Err.Description On Error GoTo 0 done: ' 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() oXlWbk0.Sheets(aArray).Move End Sub