批量提取word中内容及word文件名到excel

幻想中的猪

yylucke 发表于 2018-6-27 15:24
请参见附件

感谢大侠帮我解决了问题。还有后续的问题想继续请教下：
1、我尝试过复制代码到其他表发现没起效，后来看代码发现其中有sheet1字样，是否表示到其他表中使用就修改这处的表名即可？
2、 Sheet1.Cells(LastRow, 10) = Trim(Split(Split(Split(.Range, "到期时间")(1), Chr(13))(1), Chr(7))(1))这句话我懂，但是我能看出效果是取到期时间后的值，并放在第10列。通过大侠的代码我想自己增加一列，取“办理意见”，但是简单的依葫芦画瓢发现， Sheet1.Cells(LastRow, 11) = Trim(Split(Split(Split(.Range, "办理意见")(1), Chr(13))(1), Chr(7))(1))在办理意见有多个段落的时候只取了第一个回车前的内容，那么我应该如何修改呢？

幻想中的猪

yylucke 发表于 2018-6-27 15:24
请参见附件

另外还有一个问题，就是在word文件的序列中，偶尔间杂了几个内容中的格式不一样（无表格，纯文本），运行结果是：当内容中存在1-10列对应关键字时，生成一行且文件名正确取用；当不存在1-10列对应关键字时，不生成行，特殊地，当这个特别文件刚好排最后时生成一行且1-10列为空而仅取用文件名。

从结果来看，大侠的取值算法应该是取用关键字后第一个回车前的字符串。那么如何能对应夹杂在中间的纯文本word文件都分别生成一行呢，无论1-10列是否为空，有个最后的文件名也好。

jjmysjg

留下它记号

lsdongjh

1. Sub GetStrByWord()
   
2.     Dim SH As Worksheet, lngRowIndex As Long
   
3.     Dim strFileName As String, strPath As String, strTemp As String
   
4.     Dim strID As String, strName As String, strMemo As String
   
5.     Dim objDoc As Object, objTable  As Object
   
6.     Dim arrResult(1 To 1, 1 To 10) As Variant
   
7.    
   
8.     Set SH = Sheets("Sheet1")
   
9.     lngRowIndex = SH.Range("A" & Rows.Count).End(xlUp).Row
   
10.     If lngRowIndex < 2 Then lngRowIndex = 2
    
11.     SH.Range("A2:J" & lngRowIndex).ClearContents
    
12.     lngRowIndex = 2
    
13.    
    
14.     Application.ScreenUpdating = False
    
15.     Application.Cursor = xlWait
    
16.    
    
17.     strPath = ThisWorkbook.Path
    
18.     strFileName = Dir(strPath & "" & "*.doc*")
    
19.    
    
20.     Do Until strFileName = ""
    
21.         strTemp = Split(strFileName, ".")(0)
    
22.         strID = Mid(strTemp, 1, 4)
    
23.         
    
24.         strTemp = Mid(strTemp, 5)
    
25.         If InStr(strTemp, "（") > 0 Then
    
26.             strName = Split(strTemp, "（")(0)
    
27.             strMemo = Split(strTemp, "（")(1)
    
28.             strMemo = Mid(strMemo, 1, Len(strMemo) - 1)
    
29.         Else
    
30.             strName = strTemp
    
31.             strMemo = ""
    
32.         End If
    
33.         
    
34.         Set objDoc = GetObject(strPath & "" & strFileName)
    
35.         If objDoc.tables.Count > 0 Then
    
36.             Set objTable = objDoc.tables(1)
    
37.             arrResult(1, 1) = strID
    
38.             arrResult(1, 2) = strName
    
39.             arrResult(1, 3) = strMemo
    
40.             arrResult(1, 4) = Replace(objTable.Cell(2, 2).Range.Text, Chr(13) & Chr(7), "")
    
41.             arrResult(1, 5) = Replace(objTable.Cell(2, 4).Range.Text, Chr(13) & Chr(7), "")
    
42.             arrResult(1, 6) = Replace(objTable.Cell(3, 4).Range.Text, Chr(13) & Chr(7), "")
    
43.             arrResult(1, 7) = Replace(objTable.Cell(4, 2).Range.Text, Chr(13) & Chr(7), "")
    
44.             arrResult(1, 8) = Replace(objTable.Cell(4, 4).Range.Text, Chr(13) & Chr(7), "")
    
45.             arrResult(1, 9) = Replace(objTable.Cell(6, 2).Range.Text, Chr(13) & Chr(7), "")
    
46.             arrResult(1, 10) = Replace(objTable.Cell(7, 4).Range.Text, Chr(13) & Chr(7), "")
    
47.             SH.Range("A" & lngRowIndex).Resize(1, 10) = arrResult
    
48.             lngRowIndex = lngRowIndex + 1
    
49.         End If
    
50.         objDoc.Close False
    
51.         strFileName = Dir()
    
52.     Loop
    
53.         Set objDoc = Nothing
    
54.    
    
55.     Application.ScreenUpdating = True
    
56.     Application.Cursor = xlDefault
    
57.     MsgBox "导入成功！共导入信息【" & lngRowIndex - 2 & "】条"
    
58. End Sub
    
59. 
    

复制代码

幻想中的猪

lsdongjh 发表于 2018-7-6 08:52

谢谢。不过代码我试用了结果是导入“0”条。。。我用了上面的yylucke老师的做法，基本解决了问题，然后利用“办理意见”总是最后一个栏目的特点，稍微修改了语句将其后的全部字符串都引用，然后批量删除不要的字符，解决了99%的问题。

yk910914

  楼主| 发表于 2018-7-5 16:39 | 只看该作者

请问这个不能提取全部段落内容的问题是要怎么解决呢

yk910914

幻想中的猪 发表于 2018-7-5 16:39
感谢大侠帮我解决了问题。还有后续的问题想继续请教下：
1、我尝试过复制代码到其他表发现没起效，后来 ...

请问这个问题是需要怎么解决，感谢指导

spz202

yylucke 发表于 2018-6-27 15:24
请参见附件

牛逼。牛逼。牛逼。牛逼。牛逼。牛逼。

wang-way

平常心  我有时间 我来写一个  

1. 
   
2. Sub GetData()
   
3. 
   
4.     Set wb = Application.ThisWorkbook
   
5. 
   
6.     Set sht = wb.Worksheets(1)
   
7. 
   
8.     sht.UsedRange.Offset(1).Clear
   
9. 
   
10.     sht.Cells.NumberFormatLocal = "@"
    
11. 
    
12.     Set reg = CreateObject("VBScript.RegExp")
    
13. 
    
14.     With reg
    
15. 
    
16.         .Global = True
    
17. 
    
18.         .Pattern = "[一-龟]+"
    
19. 
    
20.     End With
    
21.     Set reg2 = CreateObject("VBScript.RegExp")
    
22. 
    
23.     With reg2
    
24. 
    
25.         .Global = True
    
26. 
    
27.         .Pattern = "（(.*?)）"
    
28. 
    
29.     End With
    
30. 
    
31.     fd = wb.Path & ""
    
32. 
    
33.     i = 1
    
34. 
    
35.     Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(fd).Files
    
36. 
    
37.     For Each f In fs
    
38. 
    
39.         fn = f.Name
    
40. 
    
41.         fp = f.Path
    
42. 
    
43.         If fp Like "*.doc*" And Not fp Like "*~*" Then
    
44. 
    
45.             Debug.Print fp
    
46. 
    
47.             Set doc = GetObject(fp)
    
48. 
    
49.             Set tb = doc.tables(1)
    
50. 
    
51.             i = i + 1
    
52. 
    
53.             Debug.Print doc.Name
    
54. 
    
55.             sht.Cells(i, 1).Value = Left(doc.Name, 4)
    
56. 
    
57.             sht.Cells(i, 2).Value = reg.Execute(doc.Name)(0)
    
58. 
    
59.             If reg2.test(doc.Name) Then sht.Cells(i, 3).Value = reg2.Execute(doc.Name)(0).submatches(0)
    
60. 
    
61.             sht.Cells(i, 4).Value = Application.Clean(tb.Range.Cells(3).Range.Text)
    
62. 
    
63.             sht.Cells(i, 5).Value = Application.Clean(tb.Range.Cells(5).Range.Text)
    
64. 
    
65.             sht.Cells(i, 6).Value = Application.Clean(tb.Range.Cells(9).Range.Text)
    
66. 
    
67.             sht.Cells(i, 7).Value = Application.Clean(tb.Range.Cells(11).Range.Text)
    
68. 
    
69.             sht.Cells(i, 8).Value = Application.Clean(tb.Range.Cells(13).Range.Text)
    
70. 
    
71.             sht.Cells(i, 9).Value = Application.Clean(tb.Range.Cells(19).Range.Text)
    
72. 
    
73.             sht.Cells(i, 10).Value = Application.Clean(tb.Range.Cells(23).Range.Text)
    
74. 
    
75.             sht.Cells(i, 11).Value = doc.Name
    
76. 
    
77.             doc.Close False
    
78. 
    
79.         End If
    
80.     Next
    
81. End Sub

复制代码