Consulting

Results 1 to 10 of 10

Thread: Extract Word tables to one line in Excel

  1. #1

    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!

    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

  2. #2
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    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)?
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  3. #3
    Quote Originally Posted by macropod View Post
    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

  4. #4
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    Try the following Excel macro:
    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
    Last edited by macropod; 11-06-2018 at 04:13 AM.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  5. #5
    Thank you so much. I've been looking for something like this for so long.

  6. #6
    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

  7. #7
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    It is not possible to put a multi-cell Word table into a single Excel cell as a table
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  8. #8
    Quote Originally Posted by macropod View Post
    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!
    table extraction example.jpg

  9. #9
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    As it appears from post #, that you only have a single paragraph in each cell, the code can be simplified. Try:
    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
    Last edited by macropod; 01-10-2019 at 01:21 PM.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •