[问题求助] vbs如何读取文本文档数据并汇总？

habiaosuo

文本文档1.txt原始数据格式如下
aa 张三 bb cc dd 1
aa 张三 bb cc dd 2
aa 张三 bb cc dd 3
aa 李四 bb cc dd 2
aa 李四 bb cc dd 3

目前程序

Const adVarChar = 200 
Const MaxCharacters = 255 
Const ForReading = 1 
Const ForWriting = 2 
Set DataList = CreateObject("ADOR.Recordset") 
DataList.Fields.Append "line", adVarChar, MaxCharacters 
DataList.Open 
Set objFSO = CreateObject("Scripting.FileSystemObject") 
Set objFile = objFSO.OpenTextFile("E:\1.txt", ForReading) 
Do Until objFile.AtEndOfStream 
strLine = objFile.ReadLine
str_arr=Split (strLine," ")
For i=0 to ubound(str_arr)
strLine1=str_arr(i)
next
strLine2=str_arr(1)&" "&str_arr(5) 
DataList.AddNew 
DataList("line") = strLine2 
DataList.Update 
Loop 
objFile.Close 
DataList.Sort = "line" 
DataList.MoveFirst 
Do Until DataList.EOF 
strText = strText & DataList.Fields.Item("line") & vbCrLf 
DataList.MoveNext 
Loop 
Set objFile = objFSO.OpenTextFile("E:\2.txt", ForWriting) 
objFile.WriteLine strText 
objFile.Close
复制代码

能实现结果如下

李四 2
李四 3
张三 1
张三 2
张三 3

理想状态是想要实现汇总
即： 李四 5   （2+3）
     张三 6    （1+2+3）
恳请各位大侠帮助，无比感谢，在线等结果

zhangop9

读取文本文档数据并汇总

caspar

Set objDicStr = CreateObject("Scripting.Dictionary") 
Set objDicSum = CreateObject("Scripting.Dictionary") 
Set oFSO = CreateObject("Scripting.FileSystemObject")

str = oFSO.OpenTextFile("Sample.txt").ReadAll
Set FS = oFSO.CreateTextFile("Result.txt",True)

str = replace(str,vbCrlf," ")
arrStr= split(str," ")

For t=0 to Ubound(arrStr)
  IF arrStr(t)<>"" Then
     strCheck = mid(arrStr(t),1,1)
     IF ASCW(strCheck) > 122 Then
        IF Not objDicSum.Exists(arrStr(t)) Then
           objDicSum.add arrStr(t), CInt(arrStr(t+4))
           objDicStr.add arrStr(t), arrStr(t+4)
        ELSE
           objDicSum.Item(arrStr(t)) = objDicSum.Item(arrStr(t)) + CInt(arrStr(t+4))
           objDicStr.Item(arrStr(t)) = objDicStr.Item(arrStr(t)) & "+" & arrStr(t+4)
        End IF
        t=t+4
     End IF
   End IF
Next

Names = objDicSum.keys

For t=0 to Ubound(Names)
    objDicStr.Item(Names(t)) = reOrder(objDicStr.Item(Names(t)))
    FS.WriteLine Names(t) & " " & objDicSum.Item(Names(t)) & " " & objDicStr.Item(Names(t))
Next

Set FS = Nothing
Set oFSO = Nothing
Set objDicSum = Nothing
Set objDicStr = Nothing


Function reOrder(ByVal str)
  Dim Nums() : Redim Nums(Len(str))
  arrTemp = split(str,"+")

  For i=0 to Ubound(arrTemp)
      IF arrTemp(i) <> "" Then
         n = n + 1
         Nums(n) = cint(arrTemp(i))
      End IF
  Next

  For i=1 to n-1
    For j=i+1 to n
      IF Nums(i)>Nums(j) Then
         Temp=Nums(i)
         Nums(i)=Nums(j)
         Nums(j)=Temp
      End IF
    Next
  Next
  
  outStr = "( "
  For i=1 to n-1
    outStr = outStr & Nums(i) & " + "
  Next
  outStr = outStr & Nums(n) & " )"

  reOrder = outStr

 End Function
复制代码

czjt1234

没做容错处理

所以注意要求格式正确，不能有空行，特别是最后一行

czjt1234

ReDim ArrName(1,0)
 
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextStream = objFSO.OpenTextFile("E:\1.txt", 1)
 
strLine = objTextStream.ReadLine
ArrLine = Split(strLine)
IntName = 0

ArrName(0,0) = ArrLine(1)
ArrName(1,0) = ArrLine(5)
 
Do Until objTextStream.AtEndOfStream 
    strLine = objTextStream.ReadLine
    ArrLine = Split(strLine)
    blnNew = True
    For i = 0 To IntName
        If ArrName(0,i) = ArrLine(1) Then
            ArrName(1,i) = ArrName(1,i) & "+" & ArrLine(5)
            blnNew = False
        End If
    Next
    If blnNew Then
        IntName = IntName + 1
        ReDim Preserve ArrName(1,IntName)
        ArrName(0,IntName) = ArrLine(1)
        ArrName(1,IntName) = ArrLine(5)
    End If
Loop
 
objTextStream.Close
Set objTextStream = objFSO.OpenTextFile("E:\2.txt", 8, True)
 
For i = 0 To IntName
    k = 0
    ArrOut = Split(ArrName(1,i), "+")
    For j = 0 To ubound(ArrOut)
        k = k + int(ArrOut(j))
    next
    objTextStream.WriteLine ArrName(0,i) & " " & k & " (" & ArrName(1,i) & ")"
Next
复制代码

CrLf

如果是用 gawk 就很方便的了：

gawk "{ar[$2]+=($6)}END{for(a in ar)print a \" \" ar[a]}" 1.txt>2.txt
复制代码

habiaosuo

急需实现这段程序，本人能力有限，恳请各位大侠帮忙，无限感激