Loop through all word documents in a folder, and extract tables and reformat and paste them in excel

[kekeda]

Hello,

I need a bit help with the below request. I need to loop through all word documents in a given folder, probably about 30-50 word documents. Each one has the same template, and I need to extract information from the first and second tables from each word document. The two tables look like something as below:

1st table

Name	A
Student id	B
Subject	C

2nd table

	Year 1	Year 2	Year 3	Year 4
Biology	D	E	F	G
Physics	H	I	J	K
Maths	L	M	N	O

I need to write a VBA script to loop through all word documents including the above 2 tables (the rest of information I do not need to extract). And then paste them all into excel line by line in the below format:

A	B	C	D	E	F	G	H	I	J
A	B	C	D	E	F	G	H	I	J
A	B	C	D	E	F	G	H	I	J

Each line above represents one word document's table information (i.e. per student).

Could something help me with that? Thanks!

 

[Andrew Fergus]

How much do you know about macros? Have you previously written your own code?

 

[kekeda]

How much do you know about macros? Have you previously written your own code?

Hi Andrew,

I have used the below code to extract tables from single word document. However, I still need to add in the loop bit and the formatting bit to the code.

Sub importTableDataWord()
Dim WdApp As Object, wddoc As Object
Dim strDocName As String
On Error Resume Next
Set WdApp = GetObject(, "Word.Application")
If Err.Number = 429 Then
Err.Clear
Set WdApp = CreateObject("Word.Application")
End If
WdApp.Visible = True

strDocName = "C:\Users\...\Work Folders\Desktop\...\....docx"

If Dir(strDocName) = "" Then
MsgBox "The file " & strDocName & vbCrLf & _
"was not found in the folder path" & vbCrLf & _
"C:\Users\...\Work Folders\Desktop\...\.", _
vbExclamation, _
"Sorry, that document name does not exist."
Exit Sub
End If

WdApp.Activate

Set wddoc = WdApp.Documents(strDocName)

If wddoc Is Nothing Then Set wddoc = WdApp.Documents.Open(strDocName)
wddoc.Activate
Dim Tble As Integer
Dim rowWd As Long
Dim colWd As Integer
Dim x As Long, y As Long
x = 1
y = 1
With wddoc
        Tble = wddoc.tables.Count
        If Tble = 0 Then
        
            MsgBox "No Tables found in the Word document", vbExclamation, "No Tables to Import"
            Exit Sub
        End If
         
         
        For i = 1 To Tble
With .tables(i)
             For rowWd = 1 To .Rows.Count
             For colWd = 1 To .Columns.Count
             Cells(x, y) = WorksheetFunction.Clean(.cell(rowWd, colWd).Range.Text)
             
                        y = y + 1
                        
                    Next colWd
                    y = 1
                    x = x + 1
                    
                Next rowWd
End With
        
        Next
    End With



wddoc.Close Savechanges:=False

WdApp.Quit


Set wddoc = Nothing
Set WdApp = Nothing


End Sub

 

[NdNoviceHlp]

Hi kekeda. U can trial this code. U will need to adjust the sheet name and folder path to suit. You will also need to fill in the "etc. etc. etc." with the remainder of your table cell transfers. Good luck. Dave

Sub XLWordTable()
Dim WrdApp As Object, Cnt As Integer, FileStr As String
Dim WrdDoc As Object, FileNm As Object, WS As Worksheet
Dim FSO As Object, FolDir As Object

Set WS = Sheets("sheet1")

On Error Resume Next
Set WrdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
On Error GoTo 0
Set WrdApp = CreateObject("Word.Application")
End If
WrdApp.Visible = False

On Error GoTo ErFix
Set FSO = CreateObject("scripting.filesystemobject")
'***change directory to suit
Set FolDir = FSO.GetFolder("D:\testfolder")

'loop files
For Each FileNm In FolDir.Files
If FileNm.Name Like "*" & ".docx" Then
FileStr = CStr(FileNm)
Set WrdDoc = WrdApp.Documents.Open(FileStr)
'check if table exists
If WrdApp.ActiveDocument.Tables.Count < 1 Then
GoTo below
End If
Cnt = Cnt + 1
'name
WS.Range("A" & Cnt) = Application.WorksheetFunction.Clean(WrdApp.ActiveDocument.Tables(1).Cell(1, 2))
'iD
WS.Range("B" & Cnt) = Application.WorksheetFunction.Clean(WrdApp.ActiveDocument.Tables(1).Cell(2, 2))
'subject
WS.Range("C" & Cnt) = Application.WorksheetFunction.Clean(WrdApp.ActiveDocument.Tables(1).Cell(3, 2))
'year1
WS.Range("D" & Cnt) = Application.WorksheetFunction.Clean(WrdApp.ActiveDocument.Tables(2).Cell(2, 2))
'year2
WS.Range("E" & Cnt) = Application.WorksheetFunction.Clean(WrdApp.ActiveDocument.Tables(2).Cell(2, 3))
'etc. etc. etc

below:
'close and don't doc
WrdApp.ActiveDocument.Close savechanges:=False
Set WrdDoc = Nothing
End If
Next FileNm

ErFix:
If Err.Number <> 0 Then
On Error GoTo 0
MsgBox "error"
End If
Set FolDir = Nothing
Set FSO = Nothing
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
End Sub

 

[kekeda]

Hi kekeda. U can trial this code. U will need to adjust the sheet name and folder path to suit. You will also need to fill in the "etc. etc. etc." with the remainder of your table cell transfers. Good luck. Dave

Sub XLWordTable()
Dim WrdApp As Object, Cnt As Integer, FileStr As String
Dim WrdDoc As Object, FileNm As Object, WS As Worksheet
Dim FSO As Object, FolDir As Object

Set WS = Sheets("sheet1")

On Error Resume Next
Set WrdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
On Error GoTo 0
Set WrdApp = CreateObject("Word.Application")
End If
WrdApp.Visible = False

On Error GoTo ErFix
Set FSO = CreateObject("scripting.filesystemobject")
'***change directory to suit
Set FolDir = FSO.GetFolder("D:\testfolder")

'loop files
For Each FileNm In FolDir.Files
If FileNm.Name Like "*" & ".docx" Then
FileStr = CStr(FileNm)
Set WrdDoc = WrdApp.Documents.Open(FileStr)
'check if table exists
If WrdApp.ActiveDocument.Tables.Count < 1 Then
GoTo below
End If
Cnt = Cnt + 1
'name
WS.Range("A" & Cnt) = Application.WorksheetFunction.Clean(WrdApp.ActiveDocument.Tables(1).Cell(1, 2))
'iD
WS.Range("B" & Cnt) = Application.WorksheetFunction.Clean(WrdApp.ActiveDocument.Tables(1).Cell(2, 2))
'subject
WS.Range("C" & Cnt) = Application.WorksheetFunction.Clean(WrdApp.ActiveDocument.Tables(1).Cell(3, 2))
'year1
WS.Range("D" & Cnt) = Application.WorksheetFunction.Clean(WrdApp.ActiveDocument.Tables(2).Cell(2, 2))
'year2
WS.Range("E" & Cnt) = Application.WorksheetFunction.Clean(WrdApp.ActiveDocument.Tables(2).Cell(2, 3))
'etc. etc. etc

below:
'close and don't doc
WrdApp.ActiveDocument.Close savechanges:=False
Set WrdDoc = Nothing
End If
Next FileNm

ErFix:
If Err.Number <> 0 Then
On Error GoTo 0
MsgBox "error"
End If
Set FolDir = Nothing
Set FSO = Nothing
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
End Sub

Hi NdNoviceHlp,

Thank you so much! It works exactly! :D

 

[NdNoviceHlp]

You are welcome. Thanks for posting your outcome. Dave