[已解决]数据读取

dyzx

请各位老师帮忙写个代码，从WORD文档中（黄色字体）数据读取到EXCEL中，多谢。

最佳答案

月排行榜 / 总排行榜

chart888

2017-6-5 12:11

1. Private Sub CommandButton1_Click()
   
2. 
   
3. Dim doc As Object
   
4. Dim p As String, f As String
   
5. Dim s As Integer
   
6. Dim arr(1 To 30000, 1 To 6) As String    '如果文件数超过，再改
   
7. 
   
8. Application.ScreenUpdating = False
   
9. Application.DisplayAlerts = False
   
10. 
    
11. p = ThisWorkbook.Path & ""
    
12. f = Dir(p & "*.doc")
    
13. i = 1
    
14. Do While Len(f) > 0
    
15.     Set doc = GetObject(p & f)
    
16.         For i = 1 To doc.tables.Count Step 1
    
17.         On Error Resume Next
    
18.         With doc.tables(i)
    
19.             A1 = zh(.cell(1, 1))
    
20.                 If A1 Like "姓名*" Then
    
21.                     s = s + 1
    
22.                     arr(s, 1) = zh(.cell(2, 2))    '班级
    
23.                     arr(s, 2) = zh(.cell(1, 2))    '姓名
    
24.                     arr(s, 3) = zh(.cell(1, 6))    '学号
    
25.                 End If
    
26.         End With
    
27.         With doc.tables(i + 1)
    
28.             A1 = zh(.cell(1, 1))
    
29.                 If A1 Like "年级*" Then
    
30.                     arr(s, 4) = zh(.cell(15, 2))    '初一
    
31.                     arr(s, 5) = zh(.cell(15, 3))    '初二
    
32.                     arr(s, 6) = zh(.cell(15, 4))    '初三
    
33.                 End If
    
34.         End With
    
35.         Next
    
36.             doc.Close False
    
37.             f = Dir()
    
38. Loop
    
39. Range("a3").Resize(s, 6) = arr
    
40. 
    
41. Application.ScreenUpdating = True
    
42. Application.DisplayAlerts = True
    
43. 
    
44. End Sub
    
45. 
    
46. Function zh(str As String) As String   '去除字符
    
47.     zh = Replace(str, Chr(13), "")
    
48.     zh = Replace(str, Chr(7), "")
    
49. End Function

复制代码

跳转到最佳答案楼层

chart888

1. Private Sub CommandButton1_Click()
   
2. 
   
3. Dim doc As Object
   
4. Dim p As String, f As String
   
5. Dim s As Integer
   
6. Dim arr(1 To 30000, 1 To 6) As String    '如果文件数超过，再改
   
7. 
   
8. Application.ScreenUpdating = False
   
9. 
   
10. p = ThisWorkbook.Path & ""
    
11. f = Dir(p & "*.doc")
    
12. Do While Len(f) > 0
    
13.     Set doc = GetObject(p & f)
    
14.     With doc.Tables(1)
    
15.         s = s + 1
    
16.         arr(s, 1) = zh(.cell(2, 2))    '班级
    
17.         arr(s, 2) = zh(.cell(1, 2))    '姓名
    
18.         arr(s, 3) = zh(.cell(1, 6))    '学号
    
19.     End With
    
20.     With doc.Tables(2)
    
21.         arr(s, 4) = zh(.cell(15, 2))    '初一
    
22.         arr(s, 5) = zh(.cell(15, 3))    '初二
    
23.         arr(s, 6) = zh(.cell(15, 4))    '初三
    
24.         doc.Close False
    
25.     End With
    
26.     f = Dir()
    
27. Loop
    
28. 
    
29.     '输出结果
    
30.     Range("a3").Resize(s, 6) = arr
    
31. End Sub
    
32. 
    
33. Function zh(str As String) As String   '去除字符
    
34.     zh = Replace(str, Chr(13), "")
    
35.     zh = Replace(str, Chr(7), "")
    
36. End Function
    
37. 
    
38. 
    

复制代码

dyzx

chart888 发表于 2017-6-2 15:51

[size=11.666666030883789px]chart888老师：我每个WORD文档中有几个分表，应该怎样读取各个人的数据，多谢指教。

dyzx

chart888 发表于 2017-6-2 15:51

chart888老师：我每个WORD文档中有几个分表，应该怎样读取各个人的数据，多谢指教。

chart888

dyzx 发表于 2017-6-5 08:07
chart888老师：我每个WORD文档中有几个分表，应该怎样读取各个人的数据，多谢指教。

教你一个笨办法你把word里面的图表复制到excel里面
然后你就看到了。。。。

希望能帮到你
给个最佳答案哈

dyzx

chart888老师：把word里面的图表复制到excel里面，然后怎样就看到了，不明。你能否将2楼代码改一下吗，多谢。

chart888

1. Private Sub CommandButton1_Click()
   
2. 
   
3. Dim doc As Object
   
4. Dim p As String, f As String
   
5. Dim s As Integer
   
6. Dim arr(1 To 30000, 1 To 6) As String    '如果文件数超过，再改
   
7. 
   
8. Application.ScreenUpdating = False
   
9. Application.DisplayAlerts = False
   
10. 
    
11. p = ThisWorkbook.Path & ""
    
12. f = Dir(p & "*.doc")
    
13. i = 1
    
14. Do While Len(f) > 0
    
15.     Set doc = GetObject(p & f)
    
16.         For i = 1 To doc.tables.Count Step 1
    
17.         On Error Resume Next
    
18.         With doc.tables(i)
    
19.             A1 = zh(.cell(1, 1))
    
20.                 If A1 Like "姓名*" Then
    
21.                     s = s + 1
    
22.                     arr(s, 1) = zh(.cell(2, 2))    '班级
    
23.                     arr(s, 2) = zh(.cell(1, 2))    '姓名
    
24.                     arr(s, 3) = zh(.cell(1, 6))    '学号
    
25.                 End If
    
26.         End With
    
27.         With doc.tables(i + 1)
    
28.             A1 = zh(.cell(1, 1))
    
29.                 If A1 Like "年级*" Then
    
30.                     arr(s, 4) = zh(.cell(15, 2))    '初一
    
31.                     arr(s, 5) = zh(.cell(15, 3))    '初二
    
32.                     arr(s, 6) = zh(.cell(15, 4))    '初三
    
33.                 End If
    
34.         End With
    
35.         Next
    
36.             doc.Close False
    
37.             f = Dir()
    
38. Loop
    
39. Range("a3").Resize(s, 6) = arr
    
40. 
    
41. Application.ScreenUpdating = True
    
42. Application.DisplayAlerts = True
    
43. 
    
44. End Sub
    
45. 
    
46. Function zh(str As String) As String   '去除字符
    
47.     zh = Replace(str, Chr(13), "")
    
48.     zh = Replace(str, Chr(7), "")
    
49. End Function

复制代码

dyzx

chart888 发表于 2017-6-5 12:11

chart888老师：多谢你的指教，多谢

chart888

dyzx 发表于 2017-6-5 14:49
chart888老师：多谢你的指教，多谢

不客气
一起学习