请教提取数据---有点复杂

tjmu

我有一组数据如下例：

>Houston

AGTTTTATATTTGATTTTTAGTAAGAAAAATAGAAACAGAAAAAAATTAATTAGTTTGGTAAAATGAATTATTTTTATAAATTAATTTATTGCT

>BISQUICK

AGTTTTATATTTGATTTTTAGTAAGAAAAATAGAAACAGAAAAAAATTAATTAGTTTGGTATTTTTATAAATTAATTTATTGCT

>BUSTER

AGTTTTATATTTGATTTTTAGTAAGAAAAATAGAAACAGAAAAAAATTAAATTAGTTTGTATTTTTATAAATTAATTTATTGCT

>JUNIOR

AGTTTTATATTTGATTTTTAGTAAGAAAAATAGAAACAGAAAAAAATTAAATTAGTTTGTTATTTTTATAAATTAATTTATTGCT

…………………

每段数据包括前面带”>”的部分和后面的各种ATCG字母。

我现在想要按照前面带”>”的标识来提取段落数据并把提取到的数据放到一个新的WORD文档中。

例如：我要提取>HOUSTON和>BUSTER这两段数据，我把这两个标识（HOUSTON和BUSTER）放在EXCEL工作表A列的第一和第二行。提取的结果放在一个新WORD文档中。

估计得VBA了，请首柔斑竹帮我。多谢。

守柔

EAkg6hzP.rar (14.66 KB, 下载次数: 17)

2005-4-11 19:54 上传

点击文件名下载附件
请教提取数据---有点复杂

以下代码供参考：

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By I Love You_Word!@ExcelHome 2005-4-11 19:52:12 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Option Explicit '请在运行该过程前确定VBE/工具/引用:引用Microsoft Excel 10.0(版本不同而异) Object Library '请将储存搜索项的EXCEL工作薄置于同本文档同一文件夹下,或者在代码中指定该工作薄路径 Sub ReadByExcelSheetWriteInWordDocument() Dim ExlApp As Excel.Application, Exlsht As Excel.Worksheet, NoFindText As String, MyRange As Range Dim XlsFileName As String, LastAddress As String, XlsRange As Excel.Range, I As Excel.Range Dim MyString As String, MyDoc As Document, FindText As String, TF As Boolean On Error Resume Next '忽略错误 With ThisDocument XlsFileName = .Path & "\LI-1.xls" '取得同一文件夹下的XLS工作薄 '将文档中的部分非段落标记的回车符全部替换为段落标记 .Content.Find.Execute FindText:="^13", replacewith:="^p", Replace:=wdReplaceAll '如果进程中没有EXCEL If Tasks.Exists("Microsoft Excel") = False Then '定义一个新的EXCEL.APPLICATION对象 Set ExlApp = New Excel.Application TF = False '设置TF值 Else '如果已有,则返回该EXCEL对象的引用 Set ExlApp = GetObject(, "Excel.Application") TF = True '设置TF值 End If '定义一个工作表对象 Set Exlsht = ExlApp.Workbooks.Open(XlsFileName).Sheets(1) With Exlsht '对于指定工作表 LastAddress = .[A65536].End(xlUp).Address '取得A列最后一行有数据单元格 Set XlsRange = .Range("A1:" & LastAddress) '定义一个EXCEL区域 End With For Each I In XlsRange '在指定的EXCEL区域中循环 Set MyRange = .Content '定义一个文档区域 With MyRange.Find '在该区域中搜索 .Text = ">" & I '设置搜索内容 .MatchCase = False '不区分大小写 .Wrap = wdFindContinue '继续查找 .Execute '执行指定的查找 If .Found = False Then '如果没有找到 '定义一个STRING变量 NoFindText = ">" & I & Chr(13) & "Word未搜索到此查找项!" FindText = NoFindText '定义一个文本变量 Else '反之则MYRANGE区域会重新自动定义为该段落到下一个段落的结束 Set MyRange = ThisDocument.Range(MyRange.Start, MyRange.Next(wdParagraph, 1).End) FindText = MyRange.Text '定义一个文本变量为 End If '在内存中累加 MyString = MyString & FindText End With Next I Set MyDoc = Documents.Add '定义一个新文档(活动文档) Selection.InsertAfter MyString '插入内存中的文本变量 End With Set Exlsht = Nothing '释放该对象 '如果TF=FALSE则退出EXCEL,并释放该变量对象 If TF = False Then ExlApp.Quit: Set ExlApp = Nothing End Sub '----------------------

tjmu

多谢

辛苦了