如何从多个WORD文件中提取相应的文字和数值到EXCEL里

囍相逢

WORD文件是一个报告单，里面有姓名和检验结果的数值，我想问一下达人，如何把多个文件中的姓名和数值用什么方法能放在EXCL里面，以便于统计分析。如果能把姓名相同的放在一起那就更好啦，因为文件较多，所以不能一个一个打开去复制，先谢谢大家了

幸福花开

不知道，同等中。。。

413191246se

语焉不详，无所适从，没有附件，无从下手

囍相逢

413191246se 发表于 2012-1-1 23:53
语焉不详，无所适从，没有附件，无从下手

SZ-HIV-11-321.zip (6.75 KB, 下载次数: 957)

2012-1-2 21:34 上传

点击文件名下载附件

就是从类似N个这样格式的文件中，提取出姓名和CD4 CD3 CD8的检测结果 导入EXCEL里 以便于分析其疾病感染状态

sylun

可试试如下代码。至于同姓名放在一起的问题，可在Excel中自行排序

1. Sub test()
   
2.     '程序在活动Excel文档运行
   
3.     Dim WdApp As Object, myDoc As Object
   
4.     Dim TF As Boolean, i As Integer, r As Long
   
5.     Dim aTable As Object, a(10), n As Integer
   
6.     On Error Resume Next
   
7.     With Application.FileDialog(msoFileDialogFilePicker)
   
8.         .Title = "请选定要处理的Word文档"
   
9.         .Filters.Add "Word文档", "*.doc"  '暂定扩展名为doc的Word文档
   
10.         .AllowMultiSelect = True
    
11.         If .Show <> -1 Then Exit Sub
    
12.         Set WdApp = GetObject(, "Word.Application")
    
13.         If Err <> 0 Then
    
14.             TF = True
    
15.             Set WdApp = CreateObject("Word.Application")
    
16.         End If
    
17.         'WdApp.Visible = True
    
18.         r = ActiveSheet.Range("a65536").End(xlUp).Row
    
19.         ActiveSheet.Range("A:A").NumberFormatLocal = "@"  '设置第一列（编号）的数字格式
    
20.         Application.ScreenUpdating = False
    
21.         For i = 1 To .SelectedItems.Count
    
22.             Set myDoc = WdApp.Documents.Open(.SelectedItems(i))
    
23.             For Each aTable In myDoc.Tables
    
24.                 With aTable  '暂提取10个相关数据
    
25.                     If .Range.Cells.Count = 37 Then  '以单元格数为依据对表格进行简单识别
    
26.                         a(0) = .Range.Previous(Unit:=4).Text
    
27.                         a(0) = Mid(a(0), 4, Len(a(0)) - 4)  '编号
    
28.                         a(1) = Replace(.Cell(8, 2).Range.Text, Chr(13) & Chr(7), "") '姓名
    
29.                         a(2) = Replace(.Cell(8, 4).Range.Text, Chr(13) & Chr(7), "")
    
30.                         a(3) = Replace(.Cell(8, 6).Range.Text, Chr(13) & Chr(7), "")
    
31.                         a(4) = Replace(.Cell(9, 2).Range.Text, Chr(13) & Chr(7), "")  '民族
    
32.                         a(5) = Replace(.Cell(9, 4).Range.Text, Chr(13) & Chr(7), "")
    
33.                         a(6) = Replace(.Cell(9, 6).Range.Text, Chr(13) & Chr(7), "")
    
34.                         a(7) = Replace(.Cell(10, 2).Range.Text, Chr(13) & Chr(7), "") '地址
    
35.                         a(8) = Replace(.Cell(14, 1).Range.Text, Chr(13) & Chr(7), "") 'CD4
    
36.                         a(9) = Replace(.Cell(14, 2).Range.Text, Chr(13) & Chr(7), "")
    
37.                         a(10) = Replace(.Cell(14, 3).Range.Text, Chr(13) & Chr(7), "")
    
38.                         Range(Cells(r + i, 1), Cells(r + i, 11)).Value = a
    
39.                         n = n + 1
    
40.                     End If
    
41.                 End With
    
42.             Next
    
43.             myDoc.Close False
    
44.         Next i
    
45.     End With
    
46.     If TF = True Then WdApp.Quit
    
47.     Set WdApp = Nothing
    
48.     MsgBox "提取完毕！共提取了" & n & "个Word文档。"
    
49.     Application.ScreenUpdating = True
    
50. End Sub

复制代码

木人无心

sylun 发表于 2012-1-3 11:04
可试试如下代码。至于同姓名放在一起的问题，可在Excel中自行排序

你好，我想问一下这个宏里面如果要提取其他表格样式里面的数据，我需要从那部分入手修改这段宏

sylun

木人无心 发表于 2012-1-3 11:19
你好，我想问一下这个宏里面如果要提取其他表格样式里面的数据，我需要从那部分入手修改这段宏

5楼代码中涉及表格中内容信息提取的是For each aTable ... Next这部分，是先将文档中各表格中的10个指定单元格内容（a(0)为表格前一段落的部分内容）导入数组a，然后将数组数据写入excel工作表。其中的各行代码的意思有哪行你是不清楚的？

jrtzxjh

sylun 发表于 2012-1-3 11:04
可试试如下代码。至于同姓名放在一起的问题，可在Excel中自行排序

看论坛里这么多代码，就这个写的好，运行了一下真的不错
这个写的真好，能帮忙替我写一个吗，我是一个门外汉，还请多多帮忙哈

sylun

jrtzxjh 发表于 2012-1-15 18:51
看论坛里这么多代码，就这个写的好，运行了一下真的不错
这个写的真好，能帮忙替我写一个吗，我是一个 ...

对代码大概修改了一下，注释可看前面的代码，只是单元格地址的表示方法不同（前者用cell方法，后者用cells属性）。代码如下：

1. Sub test2()
   
2.     '程序在活动Excel文档运行
   
3.     Dim WdApp As Object, myDoc As Object
   
4.     Dim TF As Boolean, i As Integer, r As Long
   
5.     Dim aTable As Object, a(15)
   
6.     Dim c As Byte, n As Integer
   
7.     On Error Resume Next
   
8.     With Application.FileDialog(msoFileDialogFilePicker)
   
9.         .Title = "请选定要处理的Word文档"
   
10.         .Filters.Add "Word文档", "*.doc"  '暂定扩展名为doc的Word文档
    
11.         .AllowMultiSelect = True
    
12.         If .Show <> -1 Then Exit Sub
    
13.         Set WdApp = GetObject(, "Word.Application")
    
14.         If Err <> 0 Then
    
15.             TF = True
    
16.             Set WdApp = CreateObject("Word.Application")
    
17.         End If
    
18.         'WdApp.Visible = True
    
19.         r = ActiveSheet.Range("a65536").End(xlUp).Row
    
20.         Application.ScreenUpdating = False
    
21.         For i = 1 To .SelectedItems.Count
    
22.             Set myDoc = WdApp.Documents.Open(.SelectedItems(i))
    
23.             For Each aTable In myDoc.Tables
    
24.                 With aTable.Range  '共提取16个相关数据
    
25.                     If .Cells(1).Range.Text Like "姓名：*" Then '以第1个单元格内容为依据对表格进行简单识别
    
26.                         For c = 0 To 3
    
27.                             a(c) = Replace(.Cells(c * 2 + 2).Range.Text, Chr(13) & Chr(7), "")
    
28.                         Next
    
29.                         For c = 4 To 15
    
30.                             a(c) = Replace(.Cells(c * 2 + 11).Range.Text, Chr(13) & Chr(7), "")
    
31.                         Next
    
32.                         Range(Cells(r + i, 1), Cells(r + i, 16)).Value = a
    
33.                         n = n + 1
    
34.                     End If
    
35.                 End With
    
36.             Next
    
37.             myDoc.Close False
    
38.         Next i
    
39.     End With
    
40.     If TF = True Then WdApp.Quit
    
41.     Set WdApp = Nothing
    
42.     MsgBox "提取完毕！共提取了" & n & "个Word文档。"
    
43.     Application.ScreenUpdating = True
    
44. End Sub

复制代码

flysky1117

{:soso_e134:}菜鸟，越看越迷糊，只能路过，不晓得死不是要发帖攒分，才能开主题