求 很繁琐的文本数据整理 VBA 解法

排序难题

原帖子见：http://club.excelhome.net/thread-494271-1-1.html

各位老师好
今有一难题。。。
之前找了很多文本整理软件，都没看到能最终实现此文本处理的工具
在EXCEL里要处理起来很是繁琐。

我是先查找 含有｛3D  文本的所有行数，然后删除，然后查找含有 :2-3 的所有行数，再删除，然后……
嗯好繁琐。。。

在此向各位老师求解，，
能不能用VBA一键解决了

问题附件见原帖附件，万分感谢  

压缩包里的：待处理就是要整理的文本，处理后的就是想要的结果的文本。。。

joforn

新加一个模块。将下面代码粘贴进去。
注意Test过程中的文件名。

1. 
   
2. Option Explicit
   
3. 
   
4. Public Function 文本处理(ByVal FileName1 As String, ByVal FileName2 As String)
   
5. 'FileName1:要处理的文件名
   
6. 'FileName2:处理后保存的文件名（注：如果文件已经存在，将删除原文件）
   
7. 
   
8.   Dim I As Long, FileL As Long
   
9.   Dim byteD() As Byte
   
10.   Dim strFiles() As String, strFile As String
    
11.   
    
12.   On Error Resume Next
    
13.   
    
14.   FileL = FileLen(FileName1)
    
15.   If FileL > 0 Then
    
16.     ReDim byteD(FileL - 1)
    
17.     FileL = FreeFile
    
18.     Open FileName1 For Binary As FileL
    
19.     Get FileL, , byteD
    
20.     Close FileL
    
21.     strFile = StrConv(byteD, vbUnicode)
    
22.     Erase byteD
    
23.     strFiles = Split(Replace(Replace(strFile, """", vbNullString), " ", vbNullString), vbCrLf)
    
24.     strFile = vbNullString
    
25.     For I = 0 To UBound(strFiles)
    
26.       Select Case True
    
27.         Case Mid(strFiles(I), 1, 1) = ":":          strFile = Mid(strFile, 1, Len(strFile) - 1) & vbCrLf
    
28.         Case IsNumeric(Split(strFiles(I), "=")(0)): strFile = strFile & Replace(Split(strFiles(I), "=")(1), " ", vbNullString)
    
29.       End Select
    
30.     Next I
    
31.     byteD = StrConv(strFile, vbFromUnicode)
    
32.     FileL = FreeFile
    
33.     If Len(Dir(FileName2, vbHidden Or vbNormal Or vbReadOnly Or vbSystem Or vbArchive)) Then
    
34.       SetAttr FileName2, vbNormal
    
35.       Kill FileName2
    
36.     End If
    
37.     Open FileName2 For Binary As FileL
    
38.     Put FileL, , byteD
    
39.     Close FileL
    
40.     Erase byteD
    
41.     Erase strFiles
    
42.     strFile = vbNullString
    
43.   End If
    
44. End Function
    
45. 
    
46. Public Sub Test()
    
47.   文本处理 ThisWorkbook.Path & "\待处理.txt", ThisWorkbook.Path & "\处理1.txt"
    
48. End Sub
    

复制代码

排序难题

嗯。。

谢谢老师到这里 解答···

alzeng

1. 
   
2. Private Sub CommandButton1_Click()
   
3.     Dim irow%, Arr(999)
   
4.     Dim str$, st$
   
5.     Dim k%, i%
   
6. 
   
7.     Open ThisWorkbook.Path & "\待处理.txt" For Input As #1
   
8.     k = 0
   
9.     i = -1
   
10.     str = ""
    
11.     Do Until EOF(1)
    
12. 
    
13.         Line Input #1, st
    
14. 
    
15.         If Mid(st, 3, 1) <> "=" Then GoTo 1
    
16. 
    
17.         k = k + 1
    
18.         str = str & Replace(Split(st, "=")(1), " ", "")
    
19.         str = Left(str, Len(str) - 1)
    
20.         If k = 3 Then
    
21.             k = 0
    
22.             i = i + 1
    
23.             Arr(i) = Left(str, Len(str) - 1)
    
24.             str = ""
    
25.         End If
    
26. 1
    
27.     Loop
    
28.     Close #1
    
29. 
    
30.     Open ThisWorkbook.Path & "\成组数据.txt" For Output As #1
    
31.     For k = 0 To i
    
32.         Print #1, Arr(k)
    
33.     Next
    
34.     Close #1
    
35. End Sub
    

复制代码