急！WORD提取数据！！！

shuiyuan

不明白提取什么？

守柔

注意事项：

1. 由于个人理解不同在起始位置和结束位置段中的文本，我是这样理解的，假设一段文本“123456789”取得要求从3开始到6结束，则程序运行的结果是“3456”，请注意！

2. 由于文档很大，尽量关闭一些不必要的程序，以加快运行速度。

3. 实际模拟运行情况：在378105个字符的WORD文档中运行本程序，EXCEL工作薄中的最大数为191176（同比例缩小10倍），行数为427行，用时9秒。

4. 是否需要分隔符可在代码中自行修改。

5. 我不知道你的运行结果要存放在WORD中还是EXCEL中（此处是在WORD中），应该是WORD中吧，如果放在EXCEL中也没有问题。

6. 是否需要将原有EXCEL中的起始值写在提取的字符中，也可以。

7. 请将本代码复制粘贴于你的WORD文档的thisdocument代码窗口中（ALT+F11进入VBE编辑器），在VBE的工具菜单/引用:引用-PROJECT对话框中找到Microsoft Excel 10.0 OBJECT LIBRARY（OFFICE版本不同，10.0是指XP）然后运行本代码。

8. 注意:EXCEL工作薄中的B列值必须>A列值,如果出现如B1<=A1,则会出错,是否需要交换AB值,看你能否保证B列肯定大于A列!

9. 如有问题或者特殊要求,可论坛上进行交流.

以下为代码：

1. '* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By 守柔(ShouRou)@ExcelHome 2005-2-19 5:34:59 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Option Explicit Sub GetGene() Dim ExlApp As Excel.Application, ExlWb As Excel.Workbook, MyRange As Excel.Range, i As Excel.Range, LastRow As Long Dim aWordRange As String, MyString As String, NewDoc As Document, TF As Boolean On Error Resume Next '忽略错误 If Tasks.Exists("Microsoft Excel") = True Then '如果已打开EXCEL TF = True: Set ExlApp = GetObject(, "Excel.Application") '直接调用该程序 Else Set ExlApp = CreateObject("Excel.Application") '创建EXCEL程序 End If With ExlApp .Visible = False '隐藏程序 Set ExlWb = .Workbooks.Open("d:\li.xls") '请在此修改文件路径,注意盘符与反斜杠和后缀名 LastRow = ExlWb.Sheets(1).[A65536].End(xlUp).Row '取得A列最后一行数据的行号 Set MyRange = ExlWb.Sheets(1).Range("A1:A" & LastRow) '指定A列区域 For Each i In MyRange '在指定的A列中循环 '取得文本值并以段落标记分隔,是否需要分隔或者其它分隔符可以自行修改 aWordRange = ActiveDocument.Range(i - 1, i.Offset(, 1)).Text & vbCrLf '累加文本值于内存中 MyString = MyString & aWordRange Next ExlWb.Close False '关闭并不保存指定工作薄 '如果本来就存在EXCEL程序则恢复正常显示反之退出程序 If TF = True Then .Visible = True Else Set ExlApp = Nothing End With Set NewDoc = Documents.Add '新建一个文档 Selection.InsertAfter MyString '插入内存中的文本 End Sub '----------------------

tjmu

斑竹很厉害，后果很严重！

呵呵我刚看的“天下无贼”中套用的哦

斑竹的确是了不起！！！！！！！

守柔

应楼主MSN要求，略作完善，以下代码供参考：

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By 守柔(ShouRou)@ExcelHome 2005-2-19 19:48:57 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Option Explicit Sub GetGene() Dim ExlApp As Excel.Application, ExlWb As Excel.Workbook, MyRange As Excel.Range, i As Excel.Range, LastRow As Long Dim aWordRange As String, MyString As String, NewDoc As Document, TF As Boolean On Error Resume Next '忽略错误 If Tasks.Exists("Microsoft Excel") = True Then '如果已打开EXCEL TF = True: Set ExlApp = GetObject(, "Excel.Application") '直接调用该程序 Else Set ExlApp = CreateObject("Excel.Application") '创建EXCEL程序 End If With ExlApp .Visible = False '隐藏程序 Set ExlWb = .Workbooks.Open("d:\li.xls") '请在此修改文件路径,注意盘符与反斜杠和后缀名 LastRow = ExlWb.Sheets(1).[A65536].End(xlUp).Row '取得A列最后一行数据的行号 Set MyRange = ExlWb.Sheets(1).Range("A1:A" & LastRow) '指定A列区域 For Each i In MyRange '在指定的A列中循环 '取得文本值并以段落标记分隔,是否需要分隔或者其它分隔符可以自行修改 aWordRange = i & "-" & i.Offset(, 1) & vbTab & ActiveDocument.Range(i - 1, i.Offset(, 1)).Text & vbCrLf '累加文本值于内存中 MyString = MyString & aWordRange Next ExlWb.Close False '关闭并不保存指定工作薄 '如果本来就存在EXCEL程序则恢复正常显示反之退出程序 If TF = True Then .Visible = True Else Set ExlApp = Nothing End With Set NewDoc = Documents.Add '新建一个文档 Selection.InsertAfter MyString '插入内存中的文本 End Sub '---------------------- Private Sub Document_Open() On Error Resume Next '以下引用EXCEL.EXE ActiveDocument.VBProject.References.AddFromFile _ "C:\Program Files\Microsoft Office\Office" & Mid(Application.Version, 1, 2) & "\Excel.exe" End Sub '----------------------

zhywin

我是刚来的。。斑竹能不能教一教呢？

tjmu

问题已解决，多谢斑竹指导！

尘土飞扬

斑竹厉害