Question

我多年来一直关注这个网站并从中学到很多东西，但这次我真的被卡住了。所以，时间让我终于注册了！： - ）

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

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

Excel文件的列应如下所示：

文件名
Factuurnummer（黄色）
Leerling（红色）
Vervaldatum（绿色）
Datum（绿松石）
Algemeen Totaal（蓝色）
Mededeling（丁香）

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

我在网上找到了一个脚本，但它只提取了表格中的所有内容并将其全部放在一个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

Answer 1

我会

阅读发票
创建一个仅由相关项组成的变量数组，其中一些需要进行处理，以便确保日期正确翻译（VBA往往以美国为中心），并且我们删除了多余的内容，非印刷字符
将每个变体数组收集为集合中的行
处理完所有文件后，将行集合写入结果数组并将其写入工作表。

编辑： 如果仔细检查，您会发现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

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

1 个答案: