Extract Word tables to one line in Excel

Hi,

I am trying to extract all tables from multiple word documents in one excel sheet. I can do it with the code below, but i need that every word document content (tables) to be on one line in excel not multiple lines. Also the name of the document is important to be at the beggining of the line and i can't find a solution for that. Can anyone help me? Thank you!

Code:

---

Option Explicit
 
Sub test()
 
Dim oWord As Word.Application
Dim oDoc As Word.Document
Dim oCell As Word.Cell
Dim tbl
Dim sPath As String
Dim sFile As String
Dim r As Long
Dim c As Long
Dim Cnt As Long
 
Application.ScreenUpdating = False
 
Set oWord = CreateObject("Word.Application")
 
sPath = "c:\Desktop\doc\" 'change the path accordingly
 
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
 
sFile = Dir(sPath & "*.doc")
 
r = 2 'starting row
c = 1 'starting column
Cnt = 0
Do While Len(sFile) > 0
    Cnt = Cnt + 1
    Set oDoc = oWord.Documents.Open(sPath & sFile)
For Each tbl In oDoc.Tables
    For Each oCell In tbl.Range.Cells
        Cells(r, c).Value = Replace(oCell.Range.Text, Chr(13) & Chr(7), "")
        c = c + 1
    Next oCell
    r = r + 1 'couple of blank rows between tables
    c = 1
Next tbl
    oDoc.Close savechanges:=False
    r = r + 1
    c = 1
    sFile = Dir
Loop
 
Application.ScreenUpdating = True
 
If Cnt = 0 Then
    MsgBox "No Word documents were found...", vbExclamation
End If
 
End Sub

---

So, if a document has 3 tables with up to 10 rows and 5 columns each, you want all those tables, rows & columns in one row in Excel? If so, how are the data for each table to be processed (e.g. across, then down, or down then across)?

Quote:

---

Originally Posted by macropod

So, if a document has 3 tables with up to 10 rows and 5 columns each, you want all those tables, rows & columns in one row in Excel? If so, how are the data for each table to be processed (e.g. across, then down, or down then across)?

---

across then down. ty

Try the following Excel macro:

Code:

---

Sub GetTableData()
'Note: this code requires a reference to the Word object model. See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document, wdTbl As Word.Table, wdCell As Word.Cell
Dim strFolder As String, strFile As String, WkSht As Worksheet, c As Long, r As Long
strFolder = GetFolder: If strFolder = "" Then GoTo ErrExit
Set WkSht = ActiveSheet: r = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
With wdApp
  .Visible = False
  strFile = Dir(strFolder & "\*.doc", vbNormal)
  While strFile <> ""
    Set wdDoc = .Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    r = r + 1: c = 1: WkSht.Cells(r, c).Value = Split(strFile, ".doc")(0)
    With wdDoc
      For Each wdTbl In .Tables
        With wdTbl.Range
          With .Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = "[^13^l]"
            .Replacement.Text = "¶"
            .Forward = True
            .Wrap = wdFindStop
            .Format = False
            .MatchWildcards = True
            .Execute Replace:=wdReplaceAll
          End With
          For Each wdCell In .Cells
            c = c + 1
            WkSht.Cells(r, c).Value = Split(wdCell.Range.Text, vbCr)(0)
          Next
        End With
      Next
      .Close SaveChanges:=False
    End With
    strFile = Dir()
  Wend
  WkSht.UsedRange.Replace What:="¶", Replacement:=Chr(10), LookAt:=xlPart, SearchOrder:=xlByRows
ErrExit:
  .Quit
End With
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
    Dim oFolder As Object
    GetFolder = ""
    Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
    If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
    Set oFolder = Nothing
End Function

---

:thumb:thumb:clap: Thank you so much. I've been looking for something like this for so long.

Hello! Here I am, asking for your help. Again. Is there any way to modify the code like putting each table from word docs in its own cell? eg: 3 docs. each of them have different number of tables. let's say doc 1 - 3 tables, doc 2 - 4 tables and doc 3 - 7 tables. The extracted data in excel should look like: 3 rows: first row - 3 cells, second row - 4 cells, third row - 7 cells. ty

It is not possible to put a multi-cell Word table into a single Excel cell as a table

Quote:

---

Originally Posted by macropod

It is not possible to put a multi-cell Word table into a single Excel cell as a table

---

I don't want the table to be inserted in a cell. I only need the text inside the table to be in one cell. The attachment is just an example. It's not necessarily the same as my documents.
Thank you for your time answering me!
Attachment 23505

As it appears from post #, that you only have a single paragraph in each cell, the code can be simplified. Try:

Code:

---

Sub GetTableData()
'Note: this code requires a reference to the Word object model. See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document, wdTbl As Word.Table, wdCell As Word.Cell
Dim strFolder As String, strFile As String, WkSht As Worksheet, c As Long, r As Long, strTmp As String
strFolder = GetFolder: If strFolder = "" Then GoTo ErrExit
Set WkSht = ActiveSheet: r = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
With wdApp
  .Visible = False
  strFile = Dir(strFolder & "\*.doc", vbNormal)
  While strFile <> ""
    r = r + 1: c = 1
    Set wdDoc = .Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    WkSht.Cells(r, c).Value = Split(strFile, ".doc")(0)
    With wdDoc
      For Each wdTbl In .Tables
        c = c + 1: strTmp = ""
        With wdTbl.Range
          For Each wdCell In .Cells
            strTmp = strTmp & Split(wdCell.Range.Text, vbCr)(0) & " "
          Next
          WkSht.Cells(r, c).Value = strTmp
        End With
      Next
      .Close SaveChanges:=False
    End With
    strFile = Dir()
  Wend
ErrExit:
  .Quit
End With
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
    Dim oFolder As Object
    GetFolder = ""
    Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
    If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
    Set oFolder = Nothing
End Function

---

It's perfect. I only had to delete the "Next" function after "WkSht.Cells(r, c).Value = strTmp". Thank you very much for everything!