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

westwindgg

请教大家，如附件中所示，如何从word中相应的位置获取相应的数据到excel表中，特别是word中有一列数据是有多行的，需要分别取到excel表中。

westwindgg

再次求助，有高手帮助吗？

westwindgg

再次求助大家！

Moneky

我的Doc2Xls应该可以帮你，http://club.excelhome.net/thread-1029709-1-1.html，下载最新版（看原帖追加说明）

wj2368

什么意思？。。。。

liu-aguang

该帖好像曾经发过.
你必须明确:不同文档中,需要提取的项目在表格中所处行列,哪些项目可能变化,哪些项目不会变化.比如"目标入组人数",在不同文件中,在其表格中的行列是不同的.这样才好写代码.

dyp1610

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

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

你太强大了！

westwindgg

dyp1610 发表于 2015-3-31 15:21
原表中有一个重复列我删除了。见附件

当word 6中的 “各参加机构信息”的列数在不同的word中不一样时，那代码运行时就只能随机取二个机构的名称？不能取全，见附件，不知应该如何修改呢？