提取不同字数的行

413191246se

* 楼主，请保存好你的原版文档，然后复制一份再应用下面的宏试试：（宏每次会自动备份原文件）

1. Sub a0222_CopyText()
   
2. 'CopyFile
   
3.     Dim oldName$, newName$, l!
   
4.     l = Timer
   
5.    
   
6.     oldName = ActiveDocument.FullName
   
7.    
   
8.     If oldName Like "*.docx" Then
   
9.         newName = Left(oldName, Len(oldName) - 5) & "_Copy" & ".docx"
   
10.     Else
    
11.         newName = Left(oldName, Len(oldName) - 4) & "_Copy" & ".doc"
    
12.     End If
    
13.    
    
14.     ActiveDocument.Close 0
    
15.     FileCopy oldName, newName
    
16.    
    
17.     Documents.Open FileName:=newName
    
18.    
    
19.     ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitBestFit
    
20.    
    
21. 'DeleteLines
    
22.     Dim i As Paragraph
    
23.     For Each i In ActiveDocument.Paragraphs
    
24.         With i.Range
    
25.             If Not .Characters.Count = 6 Then .Delete
    
26.         End With
    
27.     Next
    
28.     ActiveDocument.Save
    
29.    
    
30.     MsgBox "File Saved!" & vbCr & "Cost Time = " & Timer - l & " Seconds.", 0 + 48
    
31. End Sub

复制代码

常扬帆

413191246se 发表于 2024-2-22 02:58
* 楼主，请保存好你的原版文档，然后复制一份再应用下面的宏试试：（宏每次会自动备份原文件）

辛苦您了，600多页用时15分钟，蛮准确的。衷心感谢您！