TO SDBB、KONGGS：关于文本文件的段落重排

loquat

1.Application.ScreenUpdating = False不知道能不能提高效率
   大部分情况下，它都能至少提高一倍效率
2.使用集合或者字典应该也能提高不少

1. Option Explicit
   
2. Sub Example()
   
3. Application.ScreenUpdating = False
   
4.     Dim myFolder As FileDialog, sinStart As Single
   
5.     Dim myString As String, TimerUsed As Single
   
6.     Dim fso As Object, TxtFolderName As String
   
7.     Dim myTxt As String, txtFileName As String, NewName As String
   
8.     Dim FenDuan() As Variant, aArray, myArray() As String
   
9.     Dim DelText As String, strRep As String, i As Integer
   
10.     Dim aCollection As New Collection, bCollection As New Collection
    
11.     '以下代码以得所选文本文件的名称和文件夹名
    
12.     Set myFolder = Application.FileDialog(msoFileDialogFilePicker)
    
13.     With myFolder
    
14.         .Filters.Clear
    
15.         .AllowMultiSelect = False
    
16.         .Filters.Add "文本文件", "*.TXT"
    
17.         If .Show <> -1 Then Exit Sub
    
18.         sinStart = Timer
    
19.         txtFileName = .SelectedItems(1)
    
20.         TxtFolderName = .InitialFileName
    
21.         NewName = VBA.Replace(txtFileName, TxtFolderName, "")
    
22.         NewName = "Trim_" & NewName
    
23.         NewName = TxtFolderName & NewName  '新文件名称是在原文件夹中加上"Trim_"+原文件名
    
24.     End With
    
25.     Set myFolder = Nothing    '释放对象变量
    
26.     'Application.ScreenRefresh    '刷新屏幕
    
27.     DelText = "<<page"    '设置需要删除的文本内容
    
28.     Set fso = CreateObject("Scripting.FileSystemObject")    '创建一个系统文件
    
29.     Set a = fso.OpenTextFile(txtFileName, 1, 0)    '打开文本文件
    
30.         myTxt = a.ReadAll
    
31.         a.Close    '关闭
    
32.     FenDuan = Array(vbCrLf & "  ", " ", "　", vbCrLf & DelText, "=" & vbCrLf, vbCrLf)    '定义一些需要重理的内容,分别是回车换行符+两个空格,半角空格,全角空格,回车换行符+<<page,=+回车换行符,回车换行符
    
33.     For Each aArray In FenDuan   '使用集合提高效率
    
34.         aCollection.Add aArray
    
35.     Next
    
36.     For Each aArray In aCollection    '集合元素中循环
    
37.         Select Case aArray       '看集合元素
    
38.         Case vbCrLf & DelText    '回车换行符+<<page
    
39.             strRep = "↓" & DelText    '替换为标识文本和原标记
    
40.         Case vbCrLf & "  ", "=" & vbCrLf    '这是关键,分页标记以=号结束
    
41.             strRep = "↓"    '替换为标识文本
    
42.         Case Else    '其它全部删除
    
43.             strRep = ""
    
44.         End Select
    
45.         myTxt = VBA.Replace(myTxt, aArray, strRep)  '指定替换
    
46.     Next
    
47.     myArray = VBA.Split(myTxt, "↓")    '以标识文本分隔形成数组
    
48.     Dim bCollection As New Collection
    
49.     For Each aArray In myArray
    
50.         bCollection.Add aArray
    
51.     Next
    
52.     myTxt = ""    '初始化变量
    
53.     For Each aArray In bCollection    '在集合中循环
    
54.         If VBA.InStr(aArray, DelText) Or aArray = "" Then
    
55.         ElseIf aArray Like "第*回" Then i = i + 1
    
56.             myTxt = myTxt & vbCrLf & "　　" & aArray
    
57.         ElseIf i = 1 Then
    
58.             myTxt = myTxt & "　　" & aArray
    
59.             i = i + 1
    
60.         ElseIf i = 2 Then
    
61.             myTxt = myTxt & "　　" & aArray
    
62.             i = 0
    
63.         Else
    
64.             myTxt = myTxt & vbCrLf & "　　" & aArray
    
65.         End If
    
66.     Next
    
67.     Set a = fso.CreateTextFile(NewName, True)    '创建一个文本文件
    
68.     a.Write (myTxt)    '将内存数据写入文本文件中
    
69.     a.Close    '关闭
    
70.     TimerUsed = Timer - sinStart    '耗时
    
71.     MsgBox "程序重理文本文件共用时" & TimerUsed & "秒!", vbInformation
    
72. Application.ScreenUpdating = True
    
73. End Sub
    

复制代码