从多个Word文件中提取选择数据到Excel

Question

我一直在关注这个网站多年，并从中学到很多东西，但是这一次我真的被卡住了。所以，我终于登记了吧！ :-)

在工作中，我们有19740个需要处理的Word文档（没有谎言！）。这都是发票。为了使它更容易理解，我上传了一个文件，它可以在这里找到：http://1drv.ms/1U7SsHH

所有文件具有相同的布局和结构。我标记了需要以某种颜色提取的所有内容。我还需要第一个Excel列中每个Word文档的文件名。

Excel文件看起来应该像这样与它的列：

• 名
• Factuurnummer（黄色）
• Leerling（红色）
• Vervaldatum（绿色）
• 基准（绿松石）
• Algemeen Totaal（蓝色）
• Mededelin克（淡紫色）

注意：标记为蓝色的单元格并不总是相同的。下面是此类文件的一个例子：http://1drv.ms/1U7SFLa

我发现了一个脚本联机，但仅在表中提取的一切，并把它们都放在一个colomn ..它已经近7年以来我上次写了一个VBA脚本，所以我真的很生疏...... /惭愧

我真的很希望你们能帮我一把！提前致谢！

编辑：忘记把我现在的代码放在这里，对不起！

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

我会

• 阅读发票
• 创建一个变量数组只包含的相关项目，其中一些将需要处理，以处理确保日期是正确翻译（VBA倾向于以美国为中心），并且我们删除多余的非打印字符
• 收集每个变体阵列，将其作为集合中的一行
• after pr处理所有文件，将行集合写入结果数组并将其写入工作表。

编辑：如果你仔细研究，你会发现，totaal是在主表的子表的特定细胞。所以处理可以大大缩短。

我没有看到任何“紫丁香”，所以我没有收集Mededeling，但你应该能够从我提供的代码中弄清楚。

该代码适用于您提供的两张发票，但可能需要一些工作，具体取决于数据的可变性。

我试着保留大部分代码。

---

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 

---