I have this macro to extract tables from all the files in a particular directory. However, this file takes only one table from a particular file and only the first and the last column of the table.
I would request the power users to help in : 1) extracting all the tables in a particular file 2) The whole table from a file (ie., not just the first and last collumn) thanks. Sub GetTablesFromWord() 'this Excel file must be in 'the same folder with the Word 'document files that are to be 'processed. Dim wApp As Word.Application Dim wDoc As Word.Document Dim wTable As Word.Table Dim wCell As Word.Cell Dim basicPath As String Dim fName As String Dim myWS As Worksheet Dim xlCell As Range Dim lastRow As Long Dim rCount As Long Dim cCount As Long Dim RLC As Long Dim CLC As Long basicPath = ThisWorkbook.Path & Application.PathSeparator 'change the sheet name as required Set myWS = ThisWorkbook.Worksheets("Sheet1") 'clear any/all previous data on the sheet myWS.Cells.Clear '"open" Word Set wApp = CreateObject("Word.Application") 'get first .doc file name in the folder 'with this Excel file fName = Dir(basicPath & "*.doc*") Do While fName <> "" 'this puts the filename into column A to 'help separate the table data in Excel myWS.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = _ "FILE: [" & fName & "]" 'open the Word file wApp.Documents.Open basicPath & fName Set wDoc = wApp.Documents(1) 'if there is a table in the 'Word Document, work with it If wDoc.Tables.Count > 0 Then Set wTable = wDoc.Tables(1) rCount = wTable.Rows.Count cCount = wTable.Columns.Count For RLC = 1 To rCount lastRow = myWS.Range("A" & Rows.Count).End(xlUp).Row + 1 For CLC = 1 To cCount 'if there are merged cells in the 'Word table, an error will be 'generated - ignore the error, 'but also won't process the data On Error Resume Next Set wCell = wTable.Cell(RLC, CLC) If Err <> 0 Then Err.Clear Else If CLC = 1 Then Set xlCell = myWS.Range("A" & lastRow) xlCell = wCell Else Set xlCell = myWS.Range("B" & lastRow) xlCell = wCell End If 'trim chr$(13) chr$(7) from end of entry in Excel If InStr(xlCell, Chr$(13)) > 0 Then xlCell = Left(xlCell, InStr(xlCell, Chr$(13)) - 1) End If End If On Error GoTo 0 Next Next Set wCell = Nothing Set wTable = Nothing End If ' end of wDoc.Tables.Count test wDoc.Close False Set wDoc = Nothing fName = Dir() ' gets next .doc* filename in the folder Loop wApp.Quit Set wApp = Nothing MsgBox "Task Completed" End Sub -- ---------------------------------------------------------------------------------- Some important links for excel users: 1. Follow us on TWITTER for tips tricks and links : http://twitter.com/exceldailytip 2. Join our LinkedIN group @ http://www.linkedin.com/groups?gid=1871310 3. Excel tutorials at http://www.excel-macros.blogspot.com 4. Learn VBA Macros at http://www.quickvba.blogspot.com 5. Excel Tips and Tricks at http://exceldailytip.blogspot.com To post to this group, send email to excel-macros@googlegroups.com <><><><><><><><><><><><><><><><><><><><><><> Like our page on facebook , Just follow below link http://www.facebook.com/pages/discussexcelcom/160307843985936?v=wall&ref=ts