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

我一直在关注这个网站多年,并从中学到很多东西,但是这一次我真的被困住了。 所以,最后我来登记吧! 🙂

在工作中,我们有19740个Word文档(没有谎言!),需要处理。 这都是发票。 为了使它更容易理解,我上传了一个文件,可以在这里find: http : //1drv.ms/1U7SsHH

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

Excel文件的列应该像这样:

  • 文件名
  • Factuurnummer(黄色)
  • Leerling(红色)
  • Vervaldatum(绿色)
  • 基准(绿松石)
  • Algemeen Totaal(蓝色)
  • 梅德林(丁香)

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

我在网上find了一个脚本,但是它只提取了所有的表格,并把它全部放在一个colomn中。自从我上次写了一个VBA脚本已经快7年了,所以我真的生锈了… /惭愧

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

编辑:忘了把我现在的代码放在这里,对不起!

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 

我会

  • 阅读发票
  • 创build一个只包含相关项目的变体数组,其中一些需要处理以确保date被正确翻译(VBA倾向于以美国为中心),并且我们删除多余的,不打印的人物
  • 收集每个变体数组作为将成为一个集合的行
  • 处理完所有文件后,将行集合写入结果数组并将其写入工作表。

编辑: 如果你仔细检查,你会发现在主表子表中的特定单元格。 所以处理可以大大缩短。

我没有看到任何“淡紫色”,所以我没有收集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