新手研究半天没研究出来，希望大神帮忙修改下代码从word中提取到Excel中

ybx4646008 · 发表于 2018-8-9 11:30

哪位大哥能给个解决思路么？我自己研究嘛……新手跨程序的有点弄不明白?谢谢

zmj9151 · 发表于 2018-8-9 12:33

给你一个思路

jiminyanyan · 发表于 2018-8-9 13:11

手工活，找学生成本低点，学习也是要成本的。

mzbao · 发表于 2018-8-9 14:07

仅基于你的附件做的，请自行测试其它的。

Sub ReadFromWord()
Dim oWordApp As Object, oDoc As Object, txt$
Dim myPath$, MyName$, k%, findTxt$, Result
Dim arr, Num%, j%
'On Error Resume Next
Range("A2:G2000").ClearContents
myPath = ThisWorkbook.Path & ""
MyName = Dir(myPath & "*.doc*")
Set oWordApp = CreateObject("Word.Application")
Set oDoc = GetObject(myPath & MyName)
txt = oDoc.Range.Text
arr = Split(txt, "房屋安全鉴定报告")
Num = UBound(arr)
ReDim Result(1 To Num, 1 To 7)
For i = 1 To Num
txt = arr(i)
findTxt = RegxFind(txt, "鉴定编号：[^\u4e00-\u9fa5]*(\d+)", 0)
Result(i, 1) = Format(findTxt, "000")
findTxt = Trim(RegxFind(txt, "房屋地址：([^鉴定]+)", 0))
Result(i, 2) = findTxt
Result(i, 3) = oDoc.Tables(i * 2 - 1).Cell(1, 2).Range.Text
Result(i, 4) = oDoc.Tables(i * 2 - 1).Cell(3, 5).Range.Text
Result(i, 5) = oDoc.Tables(i * 2 - 1).Cell(7, 2).Range.Text
Result(i, 6) = oDoc.Tables(i * 2 - 1).Cell(9, 5).Range.Text
Result(i, 7) = oDoc.Tables(i * 2 - 1).Cell(16, 2).Range.Text
For j = 3 To 7
Result(i, j) = Left(Result(i, j), Len(Result(i, j)) - 1)
Next
Next
Range("A2").Resize(Num, 7).NumberFormatLocal = "@"
Range("A2").Resize(Num, 7) = Result
oDoc.Close True
oWordApp.Quit
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
On Error GoTo Err:
Set RegX = CreateObject("vbscript.regexp")
RegX.Pattern = strFind
Set objMatchs = RegX.Execute(strValue)
strTemp = objMatchs(0).SubMatches(Num)
Set RegX = Nothing
RegxFind = strTemp
Exit Function
Err:
myFind = ""
End Function

复制代码

ybx4646008 · 发表于 2018-8-9 14:24

mzbao 发表于 2018-8-9 14:07
仅基于你的附件做的，请自行测试其它的。

谢谢你的帮助，我看看，学习一下

ybx4646008 · 发表于 2018-8-9 14:26

zmj9151 发表于 2018-8-9 12:33
给你一个思路

谢谢你的帮助

mzbao · 发表于 2018-8-9 15:01

另一个思路

Sub ReadFromWord()
Dim oWordApp As Object, oDoc As Object, txt$
Dim myPath$, MyName$, k%, tempTxt$, Result(1 To 2000, 1 To 7) As String
Dim j%, pNum%, arr, JD%
'On Error Resume Next
Range("A2:G2000").ClearContents
myPath = ThisWorkbook.Path & ""
MyName = Dir(myPath & "*.doc*")
Set oWordApp = CreateObject("Word.Application")
Set oDoc = GetObject(myPath & MyName)
pNum = oDoc.Paragraphs.Count
For i = 1 To pNum
txt = oDoc.Paragraphs(i).Range.Text
If InStr(1, txt, "房屋安全鉴定报告") Then k = k + 1
If InStr(1, txt, "户主姓名") > 0 Then
tempTxt = oDoc.Paragraphs(i - 1).Range.Text
arr = Split(tempTxt, "：")
Result(k, 2) = Trim(Left(arr(1), InStr(1, arr(1), "鉴") - 1))
Result(k, 1) = Trim(arr(2))
Result(k, 3) = oDoc.Paragraphs(i + 1).Range.Text
End If
If InStr(1, txt, "第一次鉴定") Then JD = 1
If InStr(1, txt, "第二次鉴定") Then JD = 2
If InStr(1, txt, "建筑结构") Then
Result(k, 2 + JD * 2) = oDoc.Paragraphs(i + 1).Range.Text
End If
If InStr(1, txt, "房屋危险等级评定") Then
Result(k, 5) = oDoc.Paragraphs(i + 1).Range.Text
End If
If InStr(1, txt, "房屋综合等级") Then
Result(k, 7) = oDoc.Paragraphs(i + 1).Range.Text
End If
Next
For j = 3 To 7
For i = 1 To k
Result(i, j) = Left(Result(i, j), Len(Result(i, j)) - 1)
Next
Next
Range("A2").Resize(k, 7) = Result
oDoc.Close True
oWordApp.Quit
Set oWordApp = Nothing
End Sub

复制代码

ybx4646008 · 发表于 2018-8-9 16:01

zmj9151 发表于 2018-8-9 12:33
给你一个思路

你好，谢谢你的帮助，在学习你的代码思路后，还有一句不太明白，希望您能指点一下：
add = Trim(Left(addNum, posEnd)
这句是为了获取家庭地址，但是家庭地址跟编号是一个文本行，中间有空格，这句是如何来区分的呢？同时在实际运用中，有的农户运行到这一代码就中断了，希望您能帮忙解惑，谢谢……

zhangru2199 · 发表于 2018-8-9 16:20

http://club.excelhome.net/thread-1429801-1-1.html 继续帮忙解决

zmj9151 · 发表于 2018-8-9 16:42

ybx4646008 发表于 2018-8-9 16:01
你好，谢谢你的帮助，在学习你的代码思路后，还有一句不太明白，希望您能指点一下：
add = Trim(Left(ad ...

你把中断的数据发给我，我调试一下。另，自己在字符处理那里加几个debug.print add，查看一下add的输出

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

[求助] 新手研究半天没研究出来，希望大神帮忙修改下代码从word中提取到Excel中

评分

评分

评分

评分