请word vba编程高手帮忙

jockey1104

我是vba编程新手，想请问版主及版友们一个问题
我有一个word档，内容大致如下:

product 20001
abcdefghijklmnopqrstuvwxyz   <= 20001的产品概说
abcdefghijklmnopqrstuvwxyz
abcdefghijklmnopqrstuvwxyz
abcdefghijklmnopqrstuvwxyz
abcdefghijklmnopqrstuvwxyz;
abcdefghijklmnopqrstuvwxyz;


abcdefghijklmnopqrstuvwxyz <= 20001的产品细述
bcdefghijklmnopqrstuvwxyz
abcdefghijklmnopqrstuvwxyz;
abcdefghijklmnopqrstuvwxyz;
abcdefghijklmnopqrstuvwxyz;


product 20002
abcdefghijklmnopqrstuvwxyz <= 20002的产品概说
abcdefghijklmnopqrstuvwxyz
abcdefghijklmnopqrstuvwxyz
abcdefghijklmnopqrstuvwxyz;


abcdefghijklmnopqrstuvwxyz <= 20002的产品细述
abcdefghijklmnopqrstuvwxyz;
abcdefghijklmnopqrstuvwxyz;
abcdefghijklmnopqrstuvwxyz;


product 20003
abcdefghijklmnopqrstuvwxyz <= 20003的产品概说
abcdefghijklmnopqrstuvwxyz
abcdefghijklmnopqrstuvwxyz
abcdefghijklmnopqrstuvwxyz
abcdefghijklmnopqrstuvwxyz
abcdefghijklmnopqrstuvwxyz;
abcdefghijklmnopqrstuvwxyz;
abcdefghijklmnopqrstuvwxyz;


abcdefghijklmnopqrstuvwxyz  <= 20003的产品细述
bcdefghijklmnopqrstuvwxyz
abcdefghijklmnopqrstuvwxyz;
abcdefghijklmnopqrstuvwxyz;
abcdefghijklmnopqrstuvwxyz;

............................


如上所示，每种产品第一行都有产品号码
紧接着是产品概说，空两行，再接着产品细述
接着空两行，就是下个产品

我想把每个产品的"产品概说"及"产品细述"分别以"产品编号"产生新目录，存放在其下
例如:

\20001\
\20001\产品概说.doc
\20001\产品细述.doc

\20002\
\20002\产品概说.doc
\20002\产品细述.doc

............................

请问有高手可以帮我解答吗?
感激不尽~~~

[此贴子已经被作者于2007-5-15 0:27:16编辑过]

chylhr

'做了一个不知道是否完全符合楼主的意思

Sub CreatDoc()
   Dim myRange As Range, int_Temp As Integer, str_Temp As String
   Dim ActiveDoc As Document, Doc_Temp As Document, ActPath As String
   Set ActiveDoc = ActiveDocument
   ActiveDoc.Characters.Last.InsertAfter Chr(13) & Chr(13)  '为了得到全部要查找的结果，在文档最后加两个空段
   ActPath = ActiveDoc.Path   '获得文档路径
   Set myRange = ActiveDoc.Content
   With myRange.Find
      .ClearFormatting
      .Text = "[!^13]*^13^13^13"
      .Forward = True
      .Format = False
      .Wrap = wdFindStop
      .MatchWildcards = True
   End With
   Do While myRange.Find.Execute
      int_Temp = int_Temp + 1
      Set Doc_Temp = Documents.Add
      If (int_Temp Mod 2) = 1 Then    '有产品号码
         str_Temp = Left(myRange.Paragraphs(1).Range.Text, myRange.Paragraphs(1).Range.Characters.Count - 1)
         On Error Resume Next
         MkDir ActPath & "\" & str_Temp & "\"
         Doc_Temp.Content.Text = myRange.Text
         Doc_Temp.Paragraphs(1).Range.Delete
         Doc_Temp.SaveAs ActPath & "\" & str_Temp & "\" & "产品概说"
         Doc_Temp.Close
      Else                            '无产品号码
         Doc_Temp.Content.Text = myRange.Text
         Doc_Temp.SaveAs ActPath & "\" & str_Temp & "\" & "产品细述"
         Doc_Temp.Close
      End If
   Loop
End Sub

[此贴子已经被作者于2007-5-15 9:47:32编辑过]

jockey1104

兄台实在令小弟太佩服了
程序执行无误

可否麻烦兄台另一件事
就是能不能在此程序中
用selection物件，代替range物件来改写呢?
因为在文件中有些地方有其它的物件
兄台的程式在处理完后，这些物件会消失不见
故想用selection，再copy，再paste
这样应当能符合所需
再次感谢兄台

[此贴子已经被作者于2007-5-15 13:22:43编辑过]

chylhr

'2楼的代码是针对文字的,不知道您的文档中是否还有其他什么对象.内容丢失不在于selection还是range,我现在将代码修改了一下,请楼主看看运行是否还有问题.如果还有问题的话,我想您最好能把原文件上传.以便分析,如果您的文件需要保密的话,可以将里面的文字修改后上传.

Sub CreatDoc()
   Dim myRange As Range, int_Temp As Integer, str_Temp As String
   Dim ActiveDoc As Document, Doc_Temp As Document, ActPath As String
   Set ActiveDoc = ActiveDocument
   ActiveDoc.Characters.Last.InsertAfter Chr(13) & Chr(13)  '为了得到全部要查找的结果，在文档最后加两个空段
   ActPath = ActiveDoc.Path   '获得文档路径
   Set myRange = ActiveDoc.Content
   With myRange.Find
      .ClearFormatting
      .Text = "[!^13]*^13^13^13"
      .Forward = True
      .Format = False
      .Wrap = wdFindStop
      .MatchWildcards = True
   End With
   Do While myRange.Find.Execute
      int_Temp = int_Temp + 1
      myRange.Copy
      Set Doc_Temp = Documents.Add
      If (int_Temp Mod 2) = 1 Then    '有产品号码
         str_Temp = Left(myRange.Paragraphs(1).Range.Text, myRange.Paragraphs(1).Range.Characters.Count - 1)
         On Error Resume Next
         MkDir ActPath & "\" & str_Temp & "\"
         Doc_Temp.Content.Paste
         Doc_Temp.Paragraphs(1).Range.Delete
         Doc_Temp.SaveAs ActPath & "\" & str_Temp & "\" & "产品概说"
         Doc_Temp.Close
      Else                            '无产品号码
         Doc_Temp.Content.Paste
         Doc_Temp.SaveAs ActPath & "\" & str_Temp & "\" & "产品细述"
         Doc_Temp.Close
      End If
   Loop
End Sub

[此贴子已经被作者于2007-5-15 14:19:16编辑过]

jockey1104

chylhr兄台
实在是太感谢您了
物件都可以copy至新档了
原来只要改成copy&paste就可以了

真羡幕您对vba编程可以随心所欲地自在遨游
弟不知还要历练多久才能有您功力的五成
再次感谢您..

弟继续加油研究中...

chylhr

只要楼主多向几位版主与论坛中的高手请教,更关键的是你自己的勤奋,相信你一定会有很大的进步.另外值得注意的是学习的路上一旦遇到难题,千万不要气馁.