txt中相同字符的处理问题，继续昨天的问题（问题升级），of123 请进来一下

Question

txt文件内容如下：  
automatic control executive system        自动控制执行系统  
control and navigation        操纵和导航  
control room        控制室  
detector light        报告灯  
diurnal high water inequality        日潮高潮不等  
diurnal low water inequality        日潮低潮不等  
Fire Protection        防火  
matrix addressing        时频矩阵编址  
movement reporting system        船舶动态报告系统  
..........  
........  请问如何将这些批量数据改成我要的格式，我要的格式为：  
automatic control executive system ¦自动控制执行系统\r\n  
control and navigation ¦操纵和导航\r\n of123 回答：
Dim tmp As String, p1 As Integer, p2 As Integer 
Open "1.txt" For Input As #1 
Open "2.txt" For Output As #2 
Do Until EOF(1) 
    Line Input #1, tmp 
    p1 = Instr(1, tmp, "  ") 
    p2 = InstrRev(tmp, "  ") 
    tmp = Left(tmp, p1) & "¦" & Mid(tmp, p2 + 2) & "\r\n" 
    Print #2, tmp 
Loop 
Close #2 
Close #1 
很好，很强大，我完成了，
但是遇到了新问题：
txt中的相同字符处理：
....
abreast        并列
abreast        平齐
.....
比如说这两列文字，
现在我要把他变成一列：abreast |并列，平齐\r\n所有相同字符都同样处理
这该怎么办好啊？
是不是要判断字符的ASIC码啊？

Answer 1

Dim tmp As String, p1 As Integer, p2 As Integer  
type Data
   leftStr as string
   midStr  as string
   RigStr  as string
end type
dim xx() as data
dim i    as integer
Open "1.txt" For Input As #1  Do Until EOF(1)
    redim presave xx(i) as data  
    Line Input #1, tmp  
    
    p1 = Instr(1, tmp, "  ")  
    p2 = InstrRev(tmp, "  ")  
    xx(i).leftStr= Left(tmp, p1) 
    xx(i).midStr= Mid(tmp, p2 + 2)
    xx(i).RigStr="\r\n"  
    i= i +1
Loop  
Close #2  
先保存到变量中在处理重复 leftStr 的是数据，最后写成2号文件

Answer 2

'你的题就给两行text, 无法得知你要合并的方法, 只给你思路'添加 Command1  Text1 (Multiline设为True)Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Const EM_GETLINE = &HC4
Dim str2$, rtn&, aa$, bb$, s
Private Sub Form_Load()
   Text1.Text = "abreast   并列" & vbCrLf
   Text1.Text = Text1.Text & "abreast   平齐"
End SubPrivate Sub Command1_Click()
   Open "c:\test.txt" For Output As #1
   '读第1行
   aa = Trim(Getlinetext(Text1, 0))
   s = Split(aa, " ")
   aa = Trim(s(0)) & "|" & Trim(s(UBound(s)))
   '读第2行
   bb = Trim(Getlinetext(Text1, 1))
   s = Split(bb, " ")
   bb = Trim(s(UBound(s)))
   Print #1, aa & "," & bb & "\r\n"
   Close #1
   Me.Cls
   Print aa & "," & bb & "\r\n"
   MsgBox "保存完成"
End SubPublic Function Getlinetext(TxtBox As TextBox, ByVal ntx As Long) As String
   Dim str1(255) As Byte
   str1(0) = 255
   rtn = SendMessage(TxtBox.hwnd, EM_GETLINE, ntx, str1(0))
   If rtn = 0 Then Getlinetext = "": Exit Function
   str2 = StrConv(str1, vbUnicode)
   Getlinetext = Left(str2, InStr(1, str2, Chr(0)) - 1)
End Function

Answer 3

我的意思是说，txt中文本是本词典。
A Basket of Currencies        一篮子货币
a battery        丝极电池组
A bulk carrier of 26000 dwts capacity with seven holds and of single deck construction ideal for world wide tramp operation especially bulk grain shipments with a speed of 15 knots        一艘载重
......
abreast        并列 
abreast        平齐 
......
Zulutime        世界时
zwitterion        两性离子
zyglo        荧光透视
zyglo        荧光透视法
zylonite        赛璐路他是以字母顺序安排的，现在我要作的是将所有文体变成以下格式：A Basket of Currencies|一篮子货币\r\n
a battery|丝极电池组\r\n如果碰到相同的字符，如：
abreast        并列 
abreast        平齐 
和
zyglo        荧光透视
zyglo       荧光透视法进行合并，变成
abreast  |并列，平齐\r\n 和
zyglo  |荧光透视，荧光透视法\r\n 

Answer 4

哦，谢谢vbman2003 我是新来的，不知道这里的规矩。
谢谢告诉

Answer 5

6F 说的没错, 虽然分数不算什么也不能当饭吃, 即使 1 分结帖,解决了问题与否都说声谢谢, 这是最基本的做人原则,
当然新来的情有可原, 呵呵,俺也是上个月月底才来的, 也算是新人.....Option Explicit
Dim str2$, rtn&, aa$, bb$, i&, jj&, kk&, sPrivate Sub Form_Load()
   aa = "abreast   并列" & vbCrLf
   aa = aa & "abreast   平齐" & vbCrLf
   aa = aa & "Zulutime  世界时" & vbCrLf
   aa = aa & "zwitterion  两性离子" & vbCrLf
   aa = aa & "zyglo  荧光透视" & vbCrLf
   aa = aa & "zyglo  荧光透视法" & vbCrLf
   aa = aa & "fruit  水果" & vbCrLf
   aa = aa & "fruit  梨子"
End SubPrivate Sub Command1_Click()
   s = Split(aa, vbNewLine)
   Open "c:\test.txt" For Output As #1
   For i = 0 To UBound(s) Step 2
      aa = Trim(s(i))
      jj = InStrRev(aa, " ")
      bb = Trim(s(i + 1)) '读下一行
      kk = InStrRev(bb, " ")
      If Trim(Mid(aa, 1, jj)) = Trim(Mid(bb, 1, kk)) Then
         Print Trim(Mid(aa, 1, jj)) & " |" & Trim(Mid(aa, jj)) & "," & Trim(Mid(bb, kk)) & "\r\n"
         Print #1, Trim(Mid(aa, 1, jj)) & " |" & Trim(Mid(aa, jj)) & "," & Trim(Mid(bb, kk)) & "\r\n"
      End If
   Next i
   Close #1
   MsgBox "保存完成"
End Sub

Answer 6

'把上面那些放到 c:\test.txt 点击 Command1 保存到 c:\test2.txt'你这种作法必需注意数据一一对称,否则差一个后面的全错了.Option Explicit
Dim aa$, bb$, i&, jj&, kk&, sPrivate Sub Form_Load()
   Open "c:\test.txt" For Input As #1
   aa = Trim(StrConv(InputB(LOF(1), 1), vbUnicode))
   Close #1
End SubPrivate Sub Command1_Click()
   s = Split(aa, vbNewLine)
   Open "c:\test2.txt" For Output As #1
   For i = 0 To UBound(s) Step 2
      aa = Trim(s(i))
      jj = InStrRev(aa, " ")
      bb = Trim(s(i + 1)) '读下一行
      kk = InStrRev(bb, " ")
      If Trim(Mid(aa, 1, jj)) = Trim(Mid(bb, 1, kk)) Then
         Print Trim(Mid(aa, 1, jj)) & " |" & Trim(Mid(aa, jj)) & "," & Trim(Mid(bb, kk)) & "\r\n"
         Print #1, Trim(Mid(aa, 1, jj)) & " |" & Trim(Mid(aa, jj)) & "," & Trim(Mid(bb, kk)) & "\r\n"
      End If
      If i + 2 >= UBound(s) Then Exit For '安全起见怕你最后一行有空行
   Next i
   Close #1
   MsgBox "保存完成"
End Sub

Answer 7

乱序的话先排序，
然后用cbm666朋友的代码。

Answer 8

用字典的示例Option Explicit
'引用 Microsoft Scripting RuntimePrivate Sub Command1_Click()
    Dim sFile As String
    Dim h As String
    Dim i As Long, k As Long
    Dim obj As Dictionary
    Dim oKey As String, oItem As String
    Dim aTmp
    '读出文本1内容到变量sFile
    h = FreeFile
    Open "d:\t1.txt" For Binary As h
        sFile = Space(LOF(h))
        Get h, , sFile
    Close
    '分解sFile按行处理，加入字典，英文部分为字典Key值
    sFile = Replace(sFile, Chr(0), "")
    Set obj = New Dictionary
    aTmp = Split(sFile, vbCrLf)
    For i = 0 To UBound(aTmp)
        If Trim(aTmp(i)) <> vbNullString Then
            k = InStrRev(Trim(aTmp(i)), Chr(32))
            oKey = Trim(Mid(aTmp(i), 1, k))    
            oItem = Trim(Mid(aTmp(i), k + 1))
            If Not obj.Exists(oKey) Then   'key不存在，添加数据       
                obj.Add oKey, oKey & "|" & oItem
            Else                           'Key存在，修改对应内容
                obj.Item(oKey) = obj.Item(oKey) & "," & oItem
            End If
            
        End If
    Next
    '将字典内容写回文本2    
    h = FreeFile
    Open "d:\t2.txt" For Output As h
        For i = 0 To obj.Count - 1
            Print #h, obj.Items(i) & "\r\n"
        Next
    Close
End Sub

Answer 9

偏方，利用 ListBox。窗体上放 List1，可以设置其 Sorted = True, Visible = False.Private Declare Function SendMessagebyString Lib _
"user32" Alias "SendMessageA" (ByVal hWND As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As String) As LongPrivate Const LB_FINDSTRINGEXACT = &H1A2    '在 ListBox 中精确查找Dim tmp As String, p1 As Integer, p2 As Integer
Dim entry As String
Dim arr() As String, i As Long, n As Long
  
Open "1.txt" For Input As #1  
Do Until EOF(1)  
    Line Input #1, tmp  
    p1 = Instr(1, tmp, "  ")  
    p2 = InstrRev(tmp, "  ")
    entry = Left(tmp, p1 - 1)
    i = SendMessagebyString(List1.hWnd, LB_FINDSTRINGEXACT, -1, entry)
    If i < 0 Then                             '如果列表中没有，添加新的列表项
        List1.AddItem entry
        List1.ItemData(List1.NewIndex) = n    '记录相关列表项的原始序号
        Redim Preserve arr(n)
        arr(n) = Mid(tmp, p2 + 2)             '在数组中添加释义项
        n = n + 1
    Else                                      '如果已有，增补释义
        arr(List1.ItemData(i)) = arr(List1.ItemData(i)) & "," & Mid(tmp, p2 + 2)
    End If
Loop
Close #1 
Open "2.txt" For Output As #1
For i = 0 To List1.ListCount - 1  
    tmp = List1.List(i) & " ¦" & arr(List1.Itemdata(i)) & "\r\n"  
    Print #2, tmp  
Next i
Close #1