Extract select data from multiple Word files to Excel - vba

Question

I've been following this site for years now and learned a lot from it, but this time I'm really stuck. So, time for me to finally register huh! :-)
At work, we have 19740 Word documents (no lie!) that need to be processed. It are all invoices. To make it more understandable, I uploaded a file, which can be found here: http://1drv.ms/1U7SsHH
All files have the same layout and structure. I marked everything that needs to get extracted in a color. I also need the filename of each Word document in the first Excel column.
The Excel file should look like something like this with its columns:
Filename
Factuurnummer (yellow)
Leerling (red)
Vervaldatum (green)
Datum (turquoise)
Algemeen Totaal (blue)
Mededeling (lilac)
Note: the cell marked blue isn't always the same. Here's an example of such file: http://1drv.ms/1U7SFLa
I found a script online, but it extracts everything in only the table and puts it all in one colomn.. It's been almost 7 years since I last wrote a VBA script, so I'm really rusty... /ashamed
I really hope that you guys can help me out here! Thanks in advance!
EDIT: forgot to place my current code here, sorry!
Sub omzetting()
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:\Users\Andy\Desktop\SGR14\edusoft\facturen\sgr14_all\kopie" 'pad waar de Edusoft Word bestanden staan
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
sFile = Dir(sPath & "*.doc")
r = 1 'start rij
c = 1 'start kolom
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(5, 6).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 "Geen Word documenten gevonden. Plaats dit Excel bestand in dezelfde map.", vbExclamation
End If
End Sub

Answer 1

I would
Read the invoice
Create a variant array that consists of only the relevant items, some of which will need to be processed so as to deal with ensuring the Dates are properly translated (VBA tends to be US-centric), and that we remove extraneous, non-printing characters
Collect each variant array as what will be a row into a collection
after processing all the files, write the row collection into a results array and write it to the worksheet.
EDIT: If you examine closely, you will find that totaal is in a particular cell in a subtable of the main table. So the processing can be shortened considerably.
I did not see anything "lilac", so I did not collect Mededeling, but you should be able to figure that out from the code I provided.
The code works on the two invoices you provided, but may need some work depending on the variability of your data.
I tried to keep most of your code.
Option Explicit
Sub omzetting()
Dim oWord As Word.Application
Dim oDoc As Word.Document
Dim sPath As String
Dim sFile As String
Dim oTbl As Word.Table
Dim colRow As Collection
Dim V(1 To 7) As Variant
Dim I As Long, J As Long
Dim vRes() As Variant
Dim rRes As Range
Set rRes = Cells(1, 1)
Set oWord = New Word.Application
Set colRow = New Collection
'Change sPath to reflect the folder in YOUR system
sPath = "d:\Users\Ron\Desktop\New Folder\" 'pad waar de Edusoft Word bestanden staan
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
sFile = Dir(sPath & "*.doc")
Do While Len(sFile) > 0
Set oDoc = oWord.Documents.Open(sPath & sFile, ReadOnly:=True)
V(1) = sPath & sFile 'Filename
Set oTbl = oDoc.Tables(1)
With oTbl
With .Range
V(2) = .Cells(11).Range.Text 'Factuumummer (yellow)
V(3) = .Cells(6).Range.Text ' Leerling (red)
V(4) = .Cells(13).Range.Text 'Vervaldatum (green)
V(5) = .Cells(15).Range.Text 'Datum (turquoise)
End With
With oTbl.Tables(2).Range
V(6) = .Cells(3).Range.Text 'Algemeen Totaal (blue)
End With
'V(7) = wherever Mededeling is
End With
'Remove unneeded characters
For J = 1 To 7
V(J) = Replace(V(J), vbCr, "")
V(J) = Replace(V(J), vbLf, "")
V(J) = Replace(V(J), Chr(7), "")
Next J
'Process dates and values
V(4) = DateSerial(Right(V(4), 4), Mid(V(4), 4, 2), Left(V(4), 2))
V(5) = DateSerial(Right(V(5), 4), Mid(V(5), 4, 2), Left(V(5), 2))
'Add to collection
colRow.Add V
oDoc.Close savechanges:=False
sFile = Dir
Loop
If colRow.Count = 0 Then
MsgBox "Geen Word documenten gevonden. Plaats dit Excel bestand in dezelfde map.", vbExclamation
End If
'Set up and populate results array
'Could dim vRes(0 to ....) and use Row 0 for column labels
ReDim vRes(1 To colRow.Count, 1 To 6)
For I = 1 To UBound(vRes, 1)
For J = 1 To UBound(vRes, 2)
vRes(I, J) = colRow(I)(J)
Next J
Next I
'write results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
.EntireColumn.AutoFit
End With
End Sub