急！！！批量提取word指定内容到Excel

jaydong0330 · 发表于 2017-5-25 23:21

因本人工作需要，急需一vba程序，望论坛大神不吝赐教！
说明：一文件夹内若干word文件，现需要将每个word内的指定内容放到excel里
QQ截图20170525231917.jpg

如图所示，再次感谢论坛的老师们！！！

急！例子.rar (31.08 KB, 下载次数: 362)

mzbao · 发表于 2017-5-27 12:29

你试试，见附件。

Sub ReadFromWord()
Dim oWordApp As Object, oDoc As Object, txt$
Dim myPath$, MyName$, k%, Result(1 To 1000, 1 To 5)
On Error Resume Next
Range("A2:E2000").ClearContents
myPath = ThisWorkbook.Path & ""
MyName = Dir(myPath & "*.doc*")
Set oWordApp = CreateObject("Word.Application")
Do While MyName <> ""
If InStr(1, MyName, "项目") Then
Set oDoc = GetObject(myPath & MyName)
txt = oDoc.Range.Text
oDoc.Close True
k = k + 1
Result(k, 1) = k
Result(k, 2) = RegxFind(txt, "(.*)竞争性谈判纪要", 0)
Result(k, 3) = RegxFind(txt, "([A-Z]{4}-\d{4}-\d{2}-\d{3})", 0)
Result(k, 4) = RegxFind(txt, "中标人为(.*)。", 0)
Result(k, 5) = RegxFind(txt, "(\d+\.?\d*)元作为最终报价", 0)
End If
MyName = Dir
Loop
Range("A2").Resize(k, 5) = Result
Set oWordApp = Nothing
End Sub
Function RegxFind(strValue As String, strFind As String, Num As Integer) As String
Dim RegX As Object, objMatchs As Object
Dim strTemp As String
Set RegX = CreateObject("vbscript.regexp")
RegX.Pattern = strFind
Set objMatchs = RegX.Execute(strValue)
strTemp = objMatchs(0).SubMatches(Num)
Set RegX = Nothing
RegxFind = strTemp
End Function

复制代码

小花鹿 · 发表于 2017-5-26 00:31

你这个模拟的附件能不能体现你真实问题的所有特点？

awsa888 · 发表于 2017-5-26 07:55

本帖最后由 awsa888 于 2017-5-26 07:59 编辑

看错了~~~~~~~~~~~~~~~~~~~~~

qcw911 · 发表于 2017-5-26 08:22

有很多事例的，这个不难q57726980

jaydong0330 · 发表于 2017-5-26 11:27

小花鹿发表于 2017-5-26 00:31
你这个模拟的附件能不能体现你真实问题的所有特点？

可以代表的，从word中提取4个内容放到excel中。

jaydong0330 · 发表于 2017-5-27 08:50

没人帮助么

loveshailyu · 发表于 2017-5-27 10:39

好多重复的文字，看看大神有没有解决方案

loveshailyu · 发表于 2017-5-27 15:01

mzbao 发表于 2017-5-27 12:29
你试试，见附件。

大神太强了

jaydong0330 · 发表于 2017-5-27 19:11

mzbao 发表于 2017-5-27 12:29
你试试，见附件。

大神，太感谢了！我先试试了！
不胜感激！！！

		自动登录	找回密码
密码			免费注册

[求助] 急！！！批量提取word指定内容到Excel