Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 3448|回复: 8

如何用EXCEL VBA采集WORD中的数据

[复制链接]
发表于 2020-11-16 15:49 | 显示全部楼层 |阅读模式
本帖最后由 hasyh2008 于 2022-6-8 22:09 编辑

已解决

有多张word文件,想采集其中的部分内容,请高手指点下。
 楼主| 发表于 2020-11-16 16:22 | 显示全部楼层
回复

使用道具 举报

 楼主| 发表于 2020-11-16 20:08 | 显示全部楼层
本帖最后由 hasyh2008 于 2020-11-30 13:26 编辑

就是速度太慢,如何提速,请高手指点指点。
回复

使用道具 举报

 楼主| 发表于 2020-11-16 21:51 | 显示全部楼层
本帖最后由 hasyh2008 于 2020-11-27 17:16 编辑

修改了下,速度有提高

数据采集.zip

43.71 KB, 下载次数: 57

回复

使用道具 举报

发表于 2020-11-27 11:16 | 显示全部楼层
不错,学习了。
回复

使用道具 举报

发表于 2020-11-30 08:40 | 显示全部楼层
学习学习
回复

使用道具 举报

发表于 2021-12-25 11:01 | 显示全部楼层
hasyh2008 发表于 2020-11-16 21:51
修改了下,速度有提高

请问一下如果要采集带某关键词的语句如何修改可以达到效果。。。
回复

使用道具 举报

发表于 2021-12-25 21:32 | 显示全部楼层
jian82372387 发表于 2021-12-25 11:01
请问一下如果要采集带某关键词的语句如何修改可以达到效果。。。

大神,要这种效果,代码要怎么修改啊??
1.png
2.png
3.png
回复

使用道具 举报

 楼主| 发表于 2022-6-8 22:08 | 显示全部楼层
本帖最后由 hasyh2008 于 2022-6-9 01:13 编辑

Sub 从WORD中导入数据()
    On Error Resume Next
    Application.ScreenUpdating = False '//关闭屏幕刷新
    Application.DisplayAlerts = False '//关闭系统提示
    Application.EnableEvents = False  '//禁止触发其他事件
    Application.StatusBar = False   '关闭系统状态条
        Dim F, X%, WD, Arr(), T As Single, Rs%
        Dim Str1$, Str2$, Str3$, Str4$
        T = Timer
        F = Application.GetOpenFilename("Word文件,*.doc*", 1, MultiSelect:=True)
        ReDim Arr(1 To UBound(F), 1 To 4)
        For X = 1 To UBound(F)
          Set WD = GetObject(F(X))
          With WD.Tables(1)
            Str1 = .Cell(1, 2).Range.Text
            Str2 = .Cell(1, 4).Range.Text
            Str3 = .Cell(1, 6).Range.Text
            Str4 = .Cell(6, 6).Range.Text
            Arr(X, 1) = VBA.Left(Str1, VBA.Len(Str1) - 2)
            Arr(X, 2) = VBA.Left(Str2, VBA.Len(Str2) - 2)
            Arr(X, 3) = Format(VBA.Left(Str3, VBA.Len(Str3) - 2), "0.00")
            Arr(X, 4) = VBA.Left(Str4, VBA.Len(Str4) - 2)
            WD.Close False
          End With
          With ActiveSheet
            .Range("A1").CurrentRegion.Offset(1) = ""
            .Range("A2").Resize(X, 4) = Arr
          End With
        Next X
        Set WD = Nothing
        MsgBox Format(Timer - T, "0.00")
    Application.StatusBar = True   '恢复系统状态条
    Application.EnableEvents = True  '//恢复触发其他事件
    Application.ScreenUpdating = True '//恢复屏幕刷新
    Application.DisplayAlerts = True '//恢复系统提示
End Sub

提取WORD表格信息.rar

370.11 KB, 下载次数: 8

回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-28 17:40 , Processed in 0.454287 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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