VBA Automated extraction of tables from word file and table processing

[thomas_w]

Hey everyone,

I'm a beginner with VBC and a bit stuck on coding the following complicated problem. Here is what I would like to do:
- I have a list of .rtf files in a folder (see example file: test.docx). These files contain multiple tables with patient medication. Each table has a header which is one paragraph/line above the table. The headers are not formatted as such, but as plain test.
- I'd like to extract all tables from all documents in my folder and place them in an excel sheet.
- I'd then like to add two new columns to the left of each table (one column labelled with name_document, one column labelled with header_table).
- Into each cell of the name_document column, I'd like to add the name of the document I extracted the table from.
- Into each cell of the header_table column, I'd like to add the name of the table, as defined by the header one paragraph/line above the table.

I found the following code to extract tables from a list of documents.

Sub ExtractTablesFromMultiDocs()
  Dim objTable As Table
  Dim objDoc As Document, objNewDoc As Document
  Dim objRange As Range
  Dim strFile As String, strFolder As String
'  Initialization
  strFolder = InputBox("Enter folder address here: ")
  strFile = Dir(strFolder & "" & "*.rtf", vbNormal)
Set objNewDoc = Documents.Add
'  Process each file in the folder.
  While strFile <> ""
    Set objDoc = Documents.Open(FileName:=strFolder & "" & strFile)
    Set objDoc = ActiveDocument
For Each objTable In objDoc.Tables
      objTable.Range.Select
      Selection.Copy
Set objRange = objNewDoc.Range
      objRange.Collapse Direction:=wdCollapseEnd
      objRange.PasteSpecial DataType:=wdPasteRTF
      objRange.Collapse Direction:=wdCollapseEnd
      objRange.Text = vbCr
    Next objTable
objDoc.Save
    objDoc.Close
    strFile = Dir()
  Wend
End Sub

Any suggestions how to amend it for my purpose? Help is much appreciated!!!

Best,
Thomas