急！高难度从word表格中获取数据到excel,分列时要重复取数据

westwindgg

Moneky 发表于 2015-3-31 10:46
我的Doc2Xls应该可以帮你，http://club.excelhome.net/thread-1029709-1-1.html，下载最新版（看原帖追加说 ...

见10楼中的附件的文件，按你的那程序，就无法使用了，你能做个示范吗？

westwindgg

再顶下求助

dyp1610

westwindgg 发表于 2015-4-3 12:07
再顶下求助

1. Sub tiqu()
   
2.     Dim dpath, Filename As String
   
3.     Dim wdapp As Word.Application
   
4.     Dim wddocument As Word.Document
   
5.     Dim arr(1 To 20), crr(1 To 100), drr(1 To 100)
   
6.     dpath = ThisWorkbook.Path
   
7.     Set wdapp = New Word.Application
   
8.     Application.ScreenUpdating = False
   
9.     Filename = Dir(dpath & "\*.doc")
   
10.     On Error Resume Next
    
11.     Do While Filename <> ""
    
12.         Set wddocument = wdapp.Documents.Open(dpath & "" & Filename)
    
13.         With wddocument
    
14.             arr(1) = .Tables(1).Cell(1, 2).Range.Text
    
15.             arr(2) = .Tables(1).Cell(1, 4).Range.Text
    
16.             arr(3) = .Tables(1).Cell(2, 4).Range.Text
    
17.             arr(4) = .Tables(1).Cell(3, 2).Range.Text
    
18.             arr(5) = .Tables(2).Cell(5, 2).Range.Text
    
19.             arr(6) = .Tables(2).Cell(6, 2).Range.Text
    
20.             arr(7) = .Tables(2).Cell(7, 2).Range.Text
    
21.             arr(8) = .Tables(2).Cell(2, 2).Range.Text
    
22.             arr(9) = .Tables(2).Cell(3, 2).Range.Text
    
23.             arr(10) = .Tables(4).Cell(5, 2).Range.Text
    
24.             arr(11) = .Tables(5).Cell(1, 1).Range.Text
    
25.             arr(12) = .Tables(6).Cell(1, 1).Range.Text
    
26.             x = .Tables(4).Rows.Count '不规格表格找处目标入组人数
    
27.             For i = 10 To x
    
28.                 str1 = Mid(.Tables(4).Cell(i, 1).Range.Text, 1, 6)
    
29.                 If str1 = "目标入组人数" Then
    
30.                     arr(15) = .Tables(4).Cell(i, 2).Range.Text
    
31.                     arr(16) = .Tables(4).Cell(i + 1, 2).Range.Text
    
32.                     i = x
    
33.                 End If
    
34.             Next i
    
35.                x1 = .Tables(7).Rows.Count '不规格表格找机构
    
36.             For m = 7 To x1
    
37.                 str1 = Replace(.Tables(7).Cell(m, 2).Range.Text, vbCr & "", "")
    
38.                 If str1 = "机构名称" Then
    
39.                     jig = x1 - m
    
40.                     For w = 1 To jig
    
41.                     crr(w) = Replace(.Tables(7).Cell(m + w, 2).Range.Text, vbCr & "", "")
    
42.                     drr(w) = Replace(.Tables(7).Cell(m + w, 3).Range.Text, vbCr & "", "")
    
43.                     Next
    
44.                     Exit For
    
45.                 End If
    
46.             Next m
    
47.             For i = 1 To 16
    
48.                 arr(i) = Replace(arr(i), vbCr & "", "")
    
49.             Next
    
50.         End With
    
51.         With Sheet1
    
52.             r = .[a65536].End(xlUp).Row + 1
    
53.             For n = 1 To jig
    
54.             arr(13) = crr(n)
    
55.             arr(14) = drr(n)
    
56.              .Range("A" & r).Resize(1, 16) = arr
    
57.              r = r + 1
    
58.            Next
    
59.         End With
    
60.         wddocument.Close
    
61.         Filename = Dir()
    
62.     Loop
    
63.     Set wddocument = Nothing
    
64.     wdapp.Quit
    
65.     Set wdapp = Nothing
    
66.     Application.ScreenUpdating = True
    
67. End Sub
    

复制代码

dyp1610

不知道你的机构有这么多，见附件：

westwindgg

dyp1610 发表于 2015-4-3 13:14
不知道你的机构有这么多，见附件：

有一个问题，CTR20130001 有“目标入组人数”和“实际入组人数”这两列和相应的值，但CTR20130002没有，按你的那代码，结果CTR20130002的信息的“O”列和“P列”值还是取得CTR20130001的值，即“国内试验252人”，而不是空值。这应该是一个bug, 请教应该如何修正呢？

dyp1610

你的表格怎么这么不规范，如果是你说的这种情况的话，在第27行代码前加入arr(15)="":arr(16)=""就行了

westwindgg

dyp1610 发表于 2015-4-3 21:55
你的表格怎么这么不规范，如果是你说的这种情况的话，在第27行代码前加入arr(15)="":arr(16)=""就行了

非常感谢！周未快乐！

13164319756

Moneky 发表于 2015-3-31 10:46
我的Doc2Xls应该可以帮你，http://club.excelhome.net/thread-1029709-1-1.html，下载最新版（看原帖追加说 ...

大神我知道你这个好用，可是老出问题，能能帮助我一下吗？

13164319756

westwindgg 发表于 2015-4-2 09:48
你太强大了！

同问这个工具怎么使用

mqcwl

非常好的工具。以后有机会可以使用下。