word根据特定文字提取当前页到另一个文档

cjy964

word根据特定文字提取当前页到另一个文档     根据文档，将包含有中级包所有文档，复制包含的一页到下一个文档，我做了一下  格式表格没有了   只有文字求大神帮忙   [backcolor=var(--im_chat_message_bg_color,#c9e7ff)]Sub 提取内容()[backcolor=var(--im_chat_message_bg_color,#c9e7ff)]    Dim temp_text, text_output As String
    i = 0
   
    Do
    With Selection.Find
        .Text = "中级包"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
    End With
    Selection.Find.Execute
    ActiveDocument.Bookmarks("\page").Range.Select
    i = i + 1
    text_output = text_output & Selection.Text & Chr(13)
        If i = 500 Then
        Exit Do
        End If
    Selection.EndKey Unit:=wdLine
    Selection.MoveRight
    Loop
   
    Documents.Add.Content.Text = text_output
    ActiveDocument.SaveAs ("H:\1.docx")  '输出成独立的word文档
   
End Sub


[color=var(--common_level2_base_color,rgba(17,31,44,0.56))]




[backcolor=var(--common_bg_z1_color,#fff)]

[backcolor=var(--common_bg_z1_color,#fff)]

[color=var(--common_level2_base_color,rgba(17,31,44,0.56))][backcolor=var(--common_bg_z1_color,#fff)]

• 
  
  • 
    
  
  
  

413191246se

楼主，复制不如删除！将不含有“中级包”的页面删除后，剩下的就全是含有该词的页面了！再另存为即可，也许你是要对某一文件夹下所有文件都如此操作，再说吧！现在我仅针对一个文档，提供一下代码，仅供参考：

1. Sub test_midpack()
   
2.     Dim i&, p&, a&
   
3.     Selection.HomeKey 6
   
4.     Do
   
5.         i = 0
   
6.         ActiveDocument.Bookmarks("\page").Range.Select '选定当前页
   
7.         With Selection.Find
   
8.             .ClearFormatting
   
9.             .Text = "中级包"
   
10.             .Replacement.Text = ""
    
11.             .Forward = True
    
12.             .MatchWildcards = True
    
13.             Do While .Execute
    
14.                 i = 1
    
15.                 If i = 1 Then Exit Do
    
16.             Loop
    
17.         End With
    
18.         If i = 1 Then
    
19.             If a = ActiveDocument.Content.Information(wdActiveEndPageNumber) Then Exit Do
    
20.             a = Selection.Information(wdActiveEndPageNumber)
    
21.             p = ActiveDocument.Content.Information(wdActiveEndPageNumber)
    
22.             If p > 1 Then Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=a + 1
    
23.             ActiveDocument.Bookmarks("\page").Range.Select
    
24.         Else
    
25.             Selection.Delete
    
26.         End If
    
27.     Loop
    
28.     ActiveDocument.SaveAs FileName:="d:\demo1.doc", FileFormat:=wdFormatDocument
    
29.     ActiveDocument.Close
    
30. End Sub

复制代码

cjy964

谢谢   也可以 的 我再 复制一封再操作   谢谢  

cjy964

413191246se 发表于 2020-5-19 01:58
楼主，复制不如删除！将不含有“中级包”的页面删除后，剩下的就全是含有该词的页面了！再另存为即可，也许 ...

好像 全部删除了  

cjy964

cjy964 发表于 2020-5-19 18:48
好像 全部删除了

看错了 很好用  再次谢谢