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

守柔 · 发表于 2006-3-24 08:29

TO SDBBS、KONGGS：关于文本文件的段落重排步兵兄，我的代码如下。孔兄，关于你的代码，我初步看了一下，未经测试。我总体的感觉，只能是方法，也就是必须根据实际情况的处理，才能更有的放矢一些。谢谢你的代码。我根据山地步兵的要求，初步作了一个程式，希望对大家有所启发，特别是大的文本文件处理，使用WORD的查找与替换，效率会很低，运行时间会很长，所以，直接在内存中处理更合适一些。 '* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By I Love You_Word@ExcelHome 2006-3-24 8:25:19 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '№ 0036^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－ Option Explicit Sub Example() Dim myFolder As FileDialog, sinStart As Single Dim myString As String, TimerUsed As Single Dim FSO As Object, A As Object, TxtFolderName As String Dim myTxt As String, txtFileName As String, NewName As String Dim FenDuan() As Variant, aArray As Variant, myArray() As String Dim DelText As String, strTemp As String, strRep As String, i As Integer '以下代码以得所选文本文件的名称和文件夹名 Set myFolder = Application.FileDialog(msoFileDialogFilePicker) With myFolder .Filters.Clear .AllowMultiSelect = False .Filters.Add "文本文件", "*.TXT" If .Show <> -1 Then Exit Sub sinStart = Timer txtFileName = .SelectedItems(1) TxtFolderName = .InitialFileName NewName = VBA.Replace(txtFileName, TxtFolderName, "") NewName = "Trim_" & NewName '新文件名称是在原文件夹中加上"Trim_"+原文件名 NewName = TxtFolderName & NewName End With Set myFolder = Nothing '释放对象变量 Application.ScreenRefresh '刷新屏幕 DelText = "< 0 Then strTemp = "" '如果包含有指定删除内容,则该变量为"" ElseIf VBA.InStr(strTemp, Chr(13)) = 0 Then strTemp = strTemp & Chr(13) '如果样本文件中没有以换行符时"换行"时,加上换行标记 End If myTxt = myTxt & strTemp '累加 Loop A.Close '关闭 FenDuan = Array(Chr(13) & " ", Chr(13), " ", "　") '定义一些需要重理的内容,分别是换行符+两个空格,单个空格,单个全角空格 For Each aArray In FenDuan If aArray = Chr(13) & " " Then strRep = "↓" Else strRep = "" '当以换行符和两个空格开始的文本时,替换为特殊符号 myTxt = VBA.Replace(myTxt, aArray, strRep) '否则,全部替换为"" Next myArray = VBA.Split(myTxt, "↓") '以特殊符号为分隔符分隔内存文本 Set A = FSO.CreateTextFile(NewName, True) '创建一个文本文件 strTemp = "" '初始化变量 For Each aArray In myArray '数组中循环 If aArray Like "第*回" Then i = i + 1 '如果找到有关键字,则I值累加 If i = 3 Then '3时累加后写入文本文件中 strTemp = strTemp & "　　" & aArray A.WriteLine (strTemp) i = 0: strTemp = "" 'I\strTemp初始化 ElseIf i > 0 Then '内存中累加 strTemp = strTemp & "　　" & aArray i = i + 1 'I值累加 Else '如果为0时,直接写入文本文件 A.WriteLine ("　　" & aArray) End If Next A.Close '关闭文本文件 TimerUsed = Timer - sinStart '耗时 MsgBox "程序重理文本文件共用时" & TimerUsed & "秒!", vbInformation End Sub '----------------------

[此贴子已经被作者于2006-3-25 6:28:33编辑过]

sdbbsdbb · 发表于 2006-3-24 09:13

收到，谢谢老大的鼎立相助，这简直在帮我延寿（一点不夸张，对于一帮整天处理大文本的电子书虫来说，能在做书过程中节省时间就是延长生命）。

不过由于水平烂了点，还米怎么看明白，本程式中真正对文本处理的部分应该是以下内容吧？

DelText = "< 0 Then '内存中累加
strTemp = strTemp & "　　" & aArray
i = i + 1 'I值累加
Else '如果为0时,直接写入文本文件
A.WriteLine ("　　" & aArray)
End If
Next

目前有二个问题，

1、DelText = "< 0 Then '内存中累加　　前是否有个IF？

2、上述内容之前好像应该有个ROR循环语句？是否还是用你原来的那个程式？

With ActiveDocument.Content
MyArray() = VBA.Split(.Text, Chr(13) + Chr(10))
.Delete
End With
For Each aArray In MyArray

守柔 · 发表于 2006-3-24 09:44

网页中粘贴时被脚本截断了。请看附件：

Tr2dCTZ7.zip (11.12 KB, 下载次数: 75)

sdbbsdbb · 发表于 2006-3-24 10:38

经试验，老大的程式处理样本的速度基本上是37－42秒钟，而且不必打开样本文本文件，同时也省去了“分页”“拼写检查”之类不必要工序的时间。我的程式（见后）需要打开文本文件（重新分页一次就得花数十秒时间），处理速度在55－1分15秒间，而且不能对样本一进行处理。总结：一个崭新的时代开始了，长文本电子书处理其实大可不必打开后再处理滴（这对于批量处理特有用，上次我对三十五个文本文件进行批处理，共用一小时多，但大部分时间都花在该死的“重新分页”与“拼写检查”上了，真正对文本处理的时间不会超过2/3），这次我再试试这个程式。。。。

FxBIQU5k.txt (2.91 KB, 下载次数: 28)

konggs · 发表于 2006-3-24 12:40

我来迟了，山兄抢沙了。

谢谢老大分享。我仔细的详细的研究一下。

守柔 · 发表于 2006-3-25 06:29

速度还可以更快的，一直没有写好。

有时也得多试，VBA帮助中的有些内容，与现时的电脑配置有些格格不入，那就是编程处理中的时间与空间的关系。

sdbbsdbbsd · 发表于 2006-3-25 09:54

同感，而且有时同样的程式，在刚打开WORD时运行的效果与用了一段时间之后的效果还不一样，也不知道是MS的BUG还是程式本身的问题。

所以，能不启动WORD本身是最简洁、最可靠的办法

konggs · 发表于 2006-3-25 10:39

打印收藏了，

我已被山兄的观念包围了。

守柔 · 发表于 2006-3-25 17:13

再次更新代码，速度至少快一倍，但对于需要删除的内容，必须有严格的规范，如《page1》=========== 最后限定为=号，如果有规律，则以下附件中的代码更适宜。

2GuNWLl2.rar (10.22 KB, 下载次数: 82)

sdbbsdbbsd · 发表于 2006-3-25 20:28

多谢老大，不过好像有问题。由于我手头的机器太慢，结果稍后再报。

我一定在晚上进行详细测试，明天请您过目，不过估计还得动动“手术”。。。

		自动登录	找回密码
密码			免费注册