比较复杂的需求，可能需要正则

编辑器有问题。
希望得到的结果是：SF A
XM 张三
李四
王五
DZ 广东省广州市天河区
SR 低保
LX 老年人;青年人;尚未成年;老年;中年
EDSF B
XM 程真
欧阳晓兰
DZ 广东省珠海市香洲区吉大
SR 离退休
LX 老年人;中年人
EDSF A
XM 吴晓光
DZ 广东省珠海市香洲区吉大
SR 离退休
LX 老年人;中年人;残疾
EDSF C
XM 张德良
DZ 广东省中山市五桂山镇
SR 工作中
LX 老年人
ED

不好意思，刚才走开了Private Sub Command1_Click()
    Open "d:\0.txt" For Binary As #1
    a$ = Trim(Input(LOF(1), #1))
    Close #1

    s = Split(a, "XM")
    For i = 1 To UBound(s)
        ss = Split(s(i), vbCrLf)
        If 0 < InStr(ss(0), ";") Then
            s1 = Split(ss(0), ";")
            ss(0) = "XM" & Join(s1, vbCrLf)
            s(i) = Join(ss, vbCrLf)
        End If
    Next i
    a = Join(s, "")

    Open "d:\1.txt" For Output As #1
    Print #1, a
    Close #1
End Sub

呵呵，修改一下
Private Sub Command1_Click()
    Open "d:\0.txt" For Binary As #1
    a$ = Trim(Input(LOF(1), #1))
    Close #1

    s = Split(a, "XM")
    For i = 1 To UBound(s)
        ss = Split(s(i), vbCrLf)
        If 0 < InStr(ss(0), ";") Then
            s1 = Split(ss(0), ";")
            ss(0) = Join(s1, vbCrLf)
            s(i) = Join(ss, vbCrLf)
        End If
    Next i
    a = Join(s, "XM")

    Open "d:\1.txt" For Output As #1
    Print #1, a
    Close #1
End Sub

Private Sub Command1_Click()
   Open "c:\11.txt" For Binary As #1
   Open "c:\22.txt" For Output As #2
   Dim tmp1 As String, tmp2() As String, tmp3() As String
   tmp1 = StrConv(InputB(LOF(1), 1), vbUnicode)
   tmp2 = Split(tmp1, vbCrLf): tmp1 = ""
   For i = 0 To UBound(tmp2)
       If InStr(tmp2(i), "XM") > 0 And InStr(tmp2(i), ";") > 0 Then
          tmp3 = Split(tmp2(i), ";")
          tmp1 = tmp1 & Join(tmp3, vbCrLf) & vbCrLf
       Else
          tmp1 = tmp1 & tmp2(i) & vbCrLf
       End If
   Next
   Print #2, tmp1
   Close #1, #2

End Sub

Sub GetNewTxt()
    Dim oJs As Object, Str$
    Dim Arr, k%    Set oJs = CreateObject("ScriptControl"): oJs.Language = "JScript"
    oJs.eval "function gets(str){return str.match(/XM [^↑]+/g,'')}"    Open App.Path & "\Test.txt" For Input As #1
    Str = Replace(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf, "↑"): Reset    Arr = Split(oJs.codeobject.gets(Str), ",")
    For k = 0 To UBound(Arr)
        Str = Replace(Str, Arr(k), Replace(Arr(k), ";", "↑"))
    Next    Str = Replace(Str, "↑", vbCrLf)
    Open App.Path & "\Test.txt" For Output As #1
    Print #1, Str: Reset
End Sub

多谢楼上各位。
想再请教LS热心大哥，如果某个目录下有很多类似上述abc.txt的文档，想批量解决。我使用您的代码如下：
Sub GetNewTxt()d = Dir(File1.Path & "\*.txt")
Do While d <> ""
    Dim oJs As Object, Str$
    Dim Arr, k%    Set oJs = CreateObject("ScriptControl"): oJs.Language = "JScript"
    oJs.eval "function gets(str){return str.match(/XM [^↑]+/g,'')}"    Open File1.Path & "\" & d For Input As #1
    Str = Replace(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf, "↑"): Reset    Arr = Split(oJs.codeobject.gets(Str), ",")
    For k = 0 To UBound(Arr)
        Str = Replace(Str, Arr(k), Replace(Arr(k), ";", "↑"))
    Next    Str = Replace(Str, "↑", vbCrLf)
    Open File1.Path & "\" & d For Output As #1
    Print #1, Str: Reset

    Close #1
    d = Dir
    Loop
End SubPrivate Sub Command1_Click()
Call GetNewTxt
End Sub会出现以下错误：
实时错误'94'
无效使用 null能帮我看看么？再次感谢！

我觉得用Fso更方便些（路径请自行修改）：Sub GetNewTxt()
    Dim oJs As Object, Str$
    Dim Arr, k%
    Dim Fso As Object, Fl    Set oJs = CreateObject("ScriptControl"): oJs.Language = "JScript"
    oJs.eval "function gets(str){return str.match(/XM [^↑]+/g,'')}"    Set Fso = CreateObject("Scripting.FileSystemObject")
    For Each Fl In Fso.getfolder(App.Path & "\").Files
        If Fl.Name Like ".txt" Then
            Open Fl For Input As #1
            Str = Replace(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf, "↑"): Reset            Arr = Split(oJs.codeobject.gets(Str), ",")
            For k = 0 To UBound(Arr)
                Str = Replace(Str, Arr(k), Replace(Arr(k), ";", "↑"))
            Next            Str = Replace(Str, "↑", vbCrLf)
            Open Fl For Output As #1
            Print #1, Str: Reset
        End If
    Next
End Sub

调试易

比较复杂的需求，可能需要正则

解决方案 »