Consulting

Results 1 to 3 of 3

Thread: extract data from multiple tables from multiple word docs into Excel

  1. #1
    VBAX Newbie
    Joined
    Sep 2020
    Posts
    4
    Location

    extract data from multiple tables from multiple word docs into Excel

    Hi,

    I am trying to find code that would let me extract data from multiple tables from multiple word docs into Excel.

    I currently have the code below but it only allows me to extract data from one table. I would like to extract data from all the tables, so all the data from one word doc would be within one excel row.

    I have looked up code and tried to figure it out by myself but to no avail.


    please help and thanks in advance!



    Option Explicit

    Sub test()

    Dim oWord As Word.Application
    Dim oDoc As Word.Document
    Dim oCell As Word.Cell
    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:\Documents\H" '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 oCell In oDoc.Tables(1).Range.Cells
    Cells(r, c).Value = Replace(oCell.Range.Text, Chr(13) & Chr(7), "")
    c = c + 1
    Next oCell
    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
    From your description, it appears that you need to add a second loop to loop through the tables. Maybe something like

    Option Explicit
    
    Sub test()
    
    Dim oWord As Object
    Dim oDoc As Object
    Dim oTable As Object
    Dim oCell As Object
    Dim sPath As String
    Dim sFile As String
    Dim r As Long
    Dim c As Long
    Dim Cnt As Long
    
        Application.ScreenUpdating = False
        On Error Resume Next
        Set oWord = GetObject(, "Word.Application")
        If Err Then
            Set oWord = CreateObject("Word.Application")
        End If
        On Error GoTo 0
        sPath = "C:\Documents\"    '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)
            If oDoc.tables.Count > 0 Then
                For Each oTable In oDoc.tables
                    For Each oCell In oTable.Range.Cells
                        Cells(r, c).value = Replace(oCell.Range.Text, Chr(13) & Chr(7), "")
                        c = c + 1
                    Next oCell
                Next oTable
                r = r + 1
                c = 1
            End If
            oDoc.Close SaveChanges:=False
            sFile = Dir
            DoEvents
        Loop
        Application.ScreenUpdating = True
        If Cnt = 0 Then
            MsgBox "No Word documents were found...", vbExclamation
        End If
    End Sub
    I take it we can assume the cell processing is what you require?
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    VBAX Newbie
    Joined
    Sep 2020
    Posts
    4
    Location
    Yes it works now! thanks very much! Yes I was interested in the cell data only.

Posting Permissions

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