如何从word中提取数据到excel表格中

794905425

压缩包中将word需要的数据已标注，怎么样提取到相应的excel表格中，用vba编写，求大佬帮助

爱疯

'入口
Sub test()
    Dim p, f, A(1 To 10 ^ 4, 1 To 6)  '指定列的范围
    Application.ScreenUpdating = False
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.doc")
    Do While f <> ""
        Call wd2arr(A, GetObject(p & f))
        Call arr2sht(A)
        f = Dir()
    Loop
End Sub

'Wd到数组
Sub wd2arr(A, wd)
    Dim n, i, j, s
    For n = 1 To wd.tables.Count
        For i = 6 To 12    '指定行的范围
            s = s + 1
            For j = 1 To UBound(A, 2)
                A(s, j) = wd.tables(n).cell(i, j)    '.Range.Text
            Next j
        Next i
    Next n
End Sub

'数组到工作表
Sub arr2sht(A)
    Sheets(3).Select
    Range("e:e").NumberFormat = "@"
    [a2:f65536] = ""
    [a2].Resize(UBound(A), UBound(A, 2)) = A
    Cells.Replace Chr(7), ""
    Cells.Replace Chr(13), ""
End Sub
将word中的部分数据导入对应excel中.rar (31.98 KB, 下载次数: 61)

2019-3-29 11:58 上传

点击文件名下载附件



这样可以吗

794905425

爱疯 发表于 2019-3-29 11:58
'入口
Sub test()
    Dim p, f, A(1 To 10 ^ 4, 1 To 6)  '指定列的范围

如果有需要添加很多表格，需要怎么修改？有的word里面有上千条表格，这个可以改进一下吗

爱疯

Option Explicit

'入口
Sub wd2sht()
    Dim p, f, k, A(1 To 10 ^ 4, 1 To 7) '指定列的范围

    '1）清除
    Application.ScreenUpdating = False
    Sheets(3).Select
    [a:g] = ""
    Range("e:e").NumberFormat = "@"


    '2）收集到数组
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.doc")
    Do While f <> ""
        Call wd2arr(A, f, k, GetObject(p & f))
        f = Dir()
    Loop

    '3）输出
    [a1:g1] = Array("姓名", "性别", "出生年月", "与户主关系", "身份证号", "备注", "文件名")
    [a2].Resize(UBound(A), UBound(A, 2)) = A
    With [a:g]
        .Replace Chr(7), ""
        .Replace Chr(13), ""
    End With

End Sub

'Wd到数组
Sub wd2arr(A, f, k, wd)
    Dim n, i, j

    For n = 1 To wd.tables.Count
        For i = 6 To 12    '行的范围
            If wd.tables(n).cell(i, 1) <> Chr(13) & Chr(7) Then

                k = k + 1
                For j = 1 To 6    '列的范围
                    A(k, j) = wd.tables(n).cell(i, j)    '.Range.Text
                Next j
                A(k, j) = f

            End If
        Next i
    Next n
End Sub

3.rar (42.23 KB, 下载次数: 47)

2019-3-29 15:36 上传

点击文件名下载附件

794905425

点击后运行错误

爱疯

请具体说明一下是怎样的错误，或发个截图

794905425

我想要达到附近的这种效果，从一个word文档中提取多个相同模板表格到excel中，因为每次处理的村所涉及的word内表格数据数量不一，但数量很多！感谢您的指导！！

794905425

我调试好了，还有一点希望您帮我弄一下，就是在没个表格中有一个户主(权利人的)信息，可以不可以也提取出来啊，我再附件里变红了，您可以把第一次发我的那个压缩包(如何在word,,,,)修改一下，然后能提取出这些信息！我将需要的内容变红了，拜托您了

爱疯

Option Explicit

'入口
Sub wd2sht()
    Dim p, f, s, A(1 To 10 ^ 4, 1 To 7)    '指定列的范围

    '1）清除
    Application.ScreenUpdating = False
    Sheets(1).Select
    [a:g] = ""
    Range("e:e").NumberFormat = "@"


    '2）收集到数组
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.doc")
    Do While f <> ""
        Call wd2arr(A, f, s, GetObject(p & f))
        f = Dir()
    Loop

    '3）输出
    [a1:g1] = Array("姓名", "性别", "出生年月", "与户主关系", "身份证号", "备注", "文件名")
    [a2].Resize(UBound(A), UBound(A, 2)) = A
    With [a:g]
        .Replace Chr(7), ""
        .Replace Chr(13), ""
    End With

End Sub

'Wd到数组
Sub wd2arr(A, f, s, wd)
    Dim n, i, j

    For n = 1 To wd.tables.Count
        With wd.tables(n)
            ''''''''''''''''''''''''''''''''''''''''''''''''''
            '1）户主
            s = s + 1
            A(s, 1) = .cell(1, 2)
            A(s, 2) = .cell(2, 2)
            A(s, 3) = .cell(2, 4)
            A(s, 4) = "户主"
            A(s, 5) = .cell(1, 4)
            A(s, 7) = f
            ''''''''''''''''''''''''''''''''''''''''''''''''''
            '2）成员
            For i = 6 To 12    '行的范围
                If .cell(i, 1) <> Chr(13) & Chr(7) Then
                    s = s + 1
                    For j = 1 To 6    '列的范围
                        A(s, j) = .cell(i, j)   '.Range.Text
                    Next j
                    A(s, j) = f
                End If
            Next i
            ''''''''''''''''''''''''''''''''''''''''''''''''''
        End With
    Next n
End Sub



4.rar (31.72 KB, 下载次数: 118)

2019-3-29 20:33 上传

点击文件名下载附件

794905425

谢谢，完美解决，麻烦您了