Excel精英培训网

 找回密码
 注册

QQ登录

只需一步,快速开始

你正在寻找更好的Excel学习教程吗?Excel技巧80集+数据透视表+函数初中高全套+VBA80集,想学的这儿全都有
查看: 942|回复: 12

[已解决] 如何从word中提取数据到excel表格中

[复制链接]
发表于 2019-3-28 19:11 | 显示全部楼层 |阅读模式
1学分
压缩包中将word需要的数据已标注,怎么样提取到相应的excel表格中,用vba编写,求大佬帮助

将word中的部分数据导入对应excel中.zip

19.33 KB, 下载次数: 28

发表于 2019-3-29 11:58 | 显示全部楼层
'入口
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, 下载次数: 23)
回复

使用道具 举报

 楼主| 发表于 2019-3-29 14:52 | 显示全部楼层
爱疯 发表于 2019-3-29 11:58
'入口
Sub test()
    Dim p, f, A(1 To 10 ^ 4, 1 To 6)  '指定列的范围

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

使用道具 举报

发表于 2019-3-29 15:36 | 显示全部楼层
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, 下载次数: 18)
回复

使用道具 举报

 楼主| 发表于 2019-3-29 18:13 | 显示全部楼层
点击后运行错误
回复

使用道具 举报

发表于 2019-3-29 19:00 | 显示全部楼层
sdf23f2.gif

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

使用道具 举报

 楼主| 发表于 2019-3-29 19:22 | 显示全部楼层
我想要达到附近的这种效果,从一个word文档中提取多个相同模板表格到excel中,因为每次处理的村所涉及的word内表格数据数量不一,但数量很多!感谢您的指导!!

1.zip

66.83 KB, 下载次数: 2

回复

使用道具 举报

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

一户一档.zip

11.6 KB, 下载次数: 5

回复

使用道具 举报

发表于 2019-3-29 20:33 | 显示全部楼层
本帖最后由 爱疯 于 2019-3-29 20:40 编辑

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, 下载次数: 34)
回复

使用道具 举报

 楼主| 发表于 2019-3-30 11:15 | 显示全部楼层
谢谢,完美解决,麻烦您了
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2019-12-13 08:31 , Processed in 0.078000 second(s), 5 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 2001-2017 Comsenz Inc.

快速回复 返回顶部 返回列表