几万行TXT文本记录如何快速除重并乱序排列呢？

Question

本帖最后由 camry82 于 2013-07-20 09:38:15 编辑

Answer 1

用数组自己排序会比你这样快很多，还有就是ListBox对于大量的数据操作效率是很低的，可以考虑换个专门用于数据操作的控件来交互。

Answer 2

10W数据，也就2秒左右：
Option Explicit' 需要引用：Microsoft Scripting Runtime
Private Sub Command1_Click()
   Dim objDict As New Dictionary
   Dim arrBuf() As String
   Dim arrOut() As String
   Dim arrIndex() As Long
   Dim i&, p&, m&, strTemp$
   
   Open App.Path & "\" & Text1.Text For Binary As #1
   arrBuf = Split(Input(LOF(1), 1), vbCrLf)
   '筛选、除重
   p = -1
   m = UBound(arrBuf)
   ReDim arrOut(m)
   For i = 0 To m
      strTemp = arrBuf(i)
      If (Len(strTemp)) Then
         If (Not objDict.Exists(strTemp)) Then
            p = p + 1
            objDict.Add strTemp, p
            arrOut(p) = strTemp
         End If
      End If
   Next
   Close
   objDict.RemoveAll
   Set objDict = Nothing
   If (p = -1) Then
      MsgBox "没有内容。", vbExclamation
      Exit Sub
   End If
   '乱序输出
   ReDim arrIndex(p)
   For i = 0 To p
      arrIndex(i) = i
   Next
   Randomize
   m = p
   For i = 0 To p
      p = Rnd() * m
      List1.AddItem arrOut(arrIndex(p))
      arrIndex(p) = arrIndex(m)
      m = m - 1
   Next
End Sub

Answer 3

用你的代码测试一下，看看，我的机子就跑了20几秒Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long' 需要引用：Microsoft Scripting Runtime
Private Sub Command1_Click()
   Dim objDict As New Dictionary
   Dim arrBuf() As String
   Dim arrOut() As String
   Dim arrIndex() As Long
   Dim i&, p&, m&, strTemp$
Dim savetime As Long
savetime = GetTickCount
   Open App.Path & "\" & Text1.Text For Binary As #1
   arrBuf = Split(Input(LOF(1), 1), vbCrLf)
   '筛选、除重
   p = -1
   m = UBound(arrBuf)
   ReDim arrOut(m)
   For i = 0 To m
      strTemp = arrBuf(i)
      If (Len(strTemp)) Then
         If (Not objDict.Exists(strTemp)) Then
            p = p + 1
            objDict.Add strTemp, p
            arrOut(p) = strTemp
         End If
      End If
   Next
   Close #1
   objDict.RemoveAll
   Set objDict = Nothing
   If (p = -1) Then
      MsgBox "没有内容。", vbExclamation
      Exit Sub
   End If
   '乱序输出
   ReDim arrIndex(p)
   For i = 0 To p
      arrIndex(i) = i
   Next
   Randomize
   m = p
   For i = 0 To p
      p = Rnd() * m
      List1.AddItem arrOut(arrIndex(p))
      arrIndex(p) = arrIndex(m)
      m = m - 1
   Next
MsgBox "耗时：" & GetTickCount - savetime & " 毫秒"
End SubPrivate Sub Command2_Click()
    Dim test As String
    Dim i As Long
Dim savetime As Long
savetime = GetTickCount
    Open App.Path & "\" & Text1.Text For Output As #1
    For i = 1 To 100000
        test = String(8 - Len(Hex(i)), "0") & Hex(i)
        Print #1, test
    Next i
    Close #1
MsgBox "耗时：" & GetTickCount - savetime & " 毫秒"
End Sub

Answer 4

你好，经测试，1Ｗ多条数据时的确很快，但当我用5Ｗ左右的数据测试时处理很快。但保存LIST1时LISTCOUNT却为负数值，并且得到的是0条记录。Dim objDict As New Dictionary
Dim arrBuf() As String
Dim arrOut() As String
Dim arrIndex() As Long
Dim i&, p&, m&, strTemp$Open App.Path & "\" & Text1.Text For Output As #1
For i = 0 To List1.ListCount
Print #1, List1.List(i)
Next
Close #1
Label1.Caption = "除重乱序总数："
Text2.Text = List1.ListCount是什么原因呢？

Answer 5

我是按一般的电脑估算的处理时间。
并没有实际测试。
但没想到 List控件的速度，慢得太出乎我的意料了。

Answer 6

数据是用你的代码生成的。
我的总共时间也就12秒多。
List控件输出数据，大约就占用了11.5秒。

Answer 7

回5Ｆ：
　　这个问题，你要怪微软的垃圾程序猿。
　　是List控件属性的问题。我的建议是，你要得到除去重复后的剩余数据，定义一个模块级的变量（或者全局变量）来保存它的值。
不要再从ListCount来得到了。
获取这个值的地方是，我的那个代码中：
Close #1
objDict.RemoveAll
在这儿，把那个p的值，再+1，就是‘除重’后的数据总数。

Answer 8

那个总数我也只是看一下，没多大用处，主要是导出LIST1到TXT时数据变成0条记录了。

Answer 9

我的这儿，在10W数据导入List1之后，它的ListCount返回值是 -31072
不是0啊。估计是，超过32767条后，它的ListCount返回值就是负的了。
　　数据再多些，超过65536，就纯粹是错误的值了。
它已经把高位的2字节‘砍’掉了。

Answer 10

那个总数我也只是看一下，没多大用处，主要是导出LIST1到TXT时数据变成0条记录了。
你这儿：
Open App.Path & "\" & Text1.Text For Output As #1
For i = 0 To List1.ListCount
Print #1, List1.List(i)
Next
不正是用到了它吗？还说“没多大用处”！

Answer 11

所以我才说用 ListBox 来做这种数据操作效率是很低的。
还有，相对来说你用 Dictionary 来搞这种排序还没有用数组自己来排序快，不信你可以用快速法自己排序看看，时间上会比你这种方式快

Answer 12

你可以测试这个代码，就是快速法数组排序Private Sub Command4_Click()
    Dim ReadArray() As String
    Dim lngArraySize As Long
    Dim strTmp As String
    Dim fs As Integer
    Dim row As Long
    Dim i As Long
    Dim j As Long
    Dim index As Long
    Dim IsCompositor As Boolean
Dim savetime As Long
savetime = GetTickCount
    '========== 把文本文件以行为单位读入字符串数组 ==========
    row = 0
    ReDim ReadArray(row)
    fs = FreeFile
    Open App.Path & "\" & Text1.Text For Input As #fs
    Do While Not EOF(fs)
    Line Input #fs, strTmp
    ReadArray(row) = strTmp
    row = row + 1
    ReDim Preserve ReadArray(row)
    Loop
    Close #fs
    lngArraySize = row - 1
    ReDim Preserve ReadArray(lngArraySize)
    
    '========== 对数组进行排序 ==========
    '快速法
    Call compositor_quick(ReadArray, 0, lngArraySize)
    
    '========== 将排序好的数组输出 ==========
    For i = 0 To lngArraySize
        List1.AddItem ReadArray(i)
    Next i
Dim overtime As Long
overtime = GetTickCount
MsgBox "耗时：" & GetTickCount - savetime & " 毫秒"
End Sub
Private Sub compositor_quick(strArray() As String, i As Long, j As Long)
    Dim m As Long, _
        n As Long, _
        temp As String, _
        strTmp As String
    m = i
    n = j
    strTmp = strArray((m + n) / 2)
    Do
        ' 从左到右找比k大的元素
        Do While (strArray(m) < strTmp And m < j)
            m = m + 1
        Loop
        ' 从右到左找比k小的元素
        Do While (strArray(n) > strTmp And n > i)
            n = n - 1
        Loop
        If m <= n Then
            ' 若找到且满足条件，则交换
            temp = strArray(m)
            strArray(m) = strArray(n)
            strArray(n) = temp
            m = m + 1
            n = n - 1
        End If
    Loop While m <= n
    If m < j Then compositor_quick strArray, m, j '/*运用递归*/
    If n > i Then compositor_quick strArray, i, n
End Sub当然还有其他的算法，比如 插入法、希尔法等等，用数组自己弄，有时候会比一些系统组件更灵活，效率更高。如果把代码移植到VC里弄，效率还有进一步提升的空间，用系统组件功能，不会有这样的随意性。

Answer 13

Dictionary 做的不是“排序”，楼主是要把重复的内容去掉。你来搞个排序，是不是把方向搞偏了？楼主最初的代码，可能就是用List控件的排序功能来进行数据剔除。
现在看来，通过控件来操作，本来效率就极低，再加上数据太多时，List控件的ListCount又是错误的值。
楼主最初的代码，运行结果看来是错得离谱啊。

Answer 14

用VB来做这些，只能说，用合理的算法尽量提高效率。
跟 C/C++、Delphi 之类的，比效率，有意思吗……你真要是注重效率，还是用汇编语言写算了。

Answer 15

真有需求时，用汇编也不是什么好奇怪的呀，即使用汇编写这种过程，代码量也大不到那去，说白了，不过是换个语言而已，不怎么用汇编的人可能觉得很这种想法有点离谱，但对于经常接触汇编的人来说，那也是很简单的事情。只不过大多数情况下，C代码编译的效率已经能够达到需求了，用汇编没必要而已。就比如VC里的strlen函数，就是直接用汇编的，这种用法一点也不奇怪，以下就是strlen的源代码;***
;strlen - return the length of a null-terminated string
;
;Purpose:
;       Finds the length in bytes of the given string, not including
;       the final null character.
;
;       Algorithm:
;       int strlen (const char * str)
;       {
;           int length = 0;
;
;           while( *str++ )
;                   ++length;
;
;           return( length );
;       }
;
;Entry:
;       const char * str - string whose length is to be computed
;
;Exit:
;       EAX = length of the string "str", exclusive of the final null byte
;
;Uses:
;       EAX, ECX, EDX
;
;Exceptions:
;
;*******************************************************************************        CODESEG        public  strlenstrlen  proc        .FPO    ( 0, 1, 0, 0, 0, 0 )string  equ     [esp + 4]        mov     ecx,string              ; ecx -> string
        test    ecx,3                   ; test if string is aligned on 32 bits
        je      short main_loopstr_misaligned:
        ; simple byte loop until string is aligned
        mov     al,byte ptr [ecx]
        inc     ecx
        test    al,al
        je      short byte_3
        test    ecx,3
        jne     short str_misaligned        add     eax,dword ptr 0         ; 5 byte nop to align label below        align   16                      ; should be redundantmain_loop:
        mov     eax,dword ptr [ecx]     ; read 4 bytes
        mov     edx,7efefeffh
        add     edx,eax
        xor     eax,-1
        xor     eax,edx
        add     ecx,4
        test    eax,81010100h
        je      short main_loop
        ; found zero byte in the loop
        mov     eax,[ecx - 4]
        test    al,al                   ; is it byte 0
        je      short byte_0
        test    ah,ah                   ; is it byte 1
        je      short byte_1
        test    eax,00ff0000h           ; is it byte 2
        je      short byte_2
        test    eax,0ff000000h          ; is it byte 3
        je      short byte_3
        jmp     short main_loop         ; taken if bits 24-30 are clear and bit
                                        ; 31 is setbyte_3:
        lea     eax,[ecx - 1]
        mov     ecx,string
        sub     eax,ecx
        ret
byte_2:
        lea     eax,[ecx - 2]
        mov     ecx,string
        sub     eax,ecx
        ret
byte_1:
        lea     eax,[ecx - 3]
        mov     ecx,string
        sub     eax,ecx
        ret
byte_0:
        lea     eax,[ecx - 4]
        mov     ecx,string
        sub     eax,ecx
        retstrlen  endp        end

Answer 16

没跑题好不好，楼主的问题就是一个效率问题，我只是介绍如何上效率更高，以及有什么方法可以让效率更高而已。即使用VC或汇编写个API给VB调用来解决这种效率也是可行而且方便的办法。

Answer 17

那个总数我也只是看一下，没多大用处，主要是导出LIST1到TXT时数据变成0条记录了。
你这儿：
Open App.Path & "\" & Text1.Text For Output As #1
For i = 0 To List1.ListCount
Print #1, List1.List(i)
Next
不正是用到了它吗？还说“没多大用处”！
哦，谢谢，那如何导出除复和乱序后的结果到TXT文本呢？

Answer 18

回27F：
　我的代码中，arrOut() 就是排除重复数据后的数据。
　有效数据量就是我在8F说的 ８F说的方法得到。
　如果说“下标范围”，就是0 ～ p的值。“如何导出除复和乱序后的结果到TXT文本呢”
　arrOut()本身就是没有排序的，应该说就是一种‘乱序’。
　如果你真要再‘乱’一下，我的代码最后把数据添加到List控件，
你把这儿改成往 txt文件中写，不就完了吗？ 

Answer 19

怎么都没人试过DICTIONAR对象啊。

Answer 20

我不是无意探讨，只是觉得“测试环境”跟实际应用的差别过大，没探讨价值。
再说，你始终在回避一个问题：数据筛选！
这应该说是不能忽略的地方。　　还有一个要说明的，我刚才忽然想到，我在6F贴图中，那个筛选数据的时间，是不正确的，它是包含读取数据的时间在内。我刚试了下单独的时间，用你的代码生成的数据，10Ｗ条，“筛选时间”是468 ms。

Answer 21

看到楼主用Listbox控件来处理大量字符串数组的需求就雷倒了：（）

Answer 22

请问 DICTIONAR对象 是什么东东啊？
如果你是少写了个Y的话，我2F的代码，难道不是用的它？ 

Answer 23

请问 DICTIONAR对象 是什么东东啊？
如果你是少写了个Y的话，我2F的代码，难道不是用的它？ 
哦哦，我就说嘛，大数据情况下，查找，排序 ，DICTIONNARY是比较快的 ，有些时候快过SQL.
但是这些都是VB6里面的 ，不知道 .NET那个DICTIONARY和 哈希 速度怎么样 。

Answer 24

不是我回避什么问题，而是这根本就不是什么问题，先不说时候直接在排序过程里做数据筛选过程，就算独立循环一次去做筛选也不会要多久时间，看你的测试环境应该比我的要强很多了，我的还是好几年前的笔记本电脑，所以速度是差点，你那里跑十多秒的过程我这要二十多秒，不过就这种有差异的环境测试这种过程，我这的10W条数据排序+剔除重复也只用了 (排序)452 ms + (筛选)62 ms，你的是筛选时间就花了 468 ms，h还没有数据排序过程。
其实如果数据有了排序，赛选可以说很简单，看看这个过程Private Sub kill_repeated(strArray() As String)
    Dim max As Long, _
        min As Long, _
        i As Long, _
        j As Long, _
        count As Long, _
        strTmp As String
    max = UBound(strArray)
    count = max
    min = LBound(strArray)
    j = 0
    
    For i = min + 1 To max
        strTmp = strArray(i - 1)
        If Len(strTmp) = 0 Then
            strArray(i - 1) = strArray(i + j)
            j = j + 1
            i = i - 1
            count = count - 1
        Else
            If strArray(i - 1) = strArray(i + j) Then
                j = j + 1
                i = i - 1
                count = count - 1
            Else
                strArray(i) = strArray(i + j)
            End If
        End If
        If i >= count Then Exit For
    Next i
    ReDim Preserve strArray(count)
End Sub这个赛选过程完全是基于排序好的数据进行筛选，所以根本不需要什么时间，我这里的10W条全反序数据被弄正序之后，只用了62 ms就完成了这种重复筛选。我测试的数据是这样来的。Private Sub Command2_Click()
    Dim test As String
    Dim i As Long
    Dim j As Long
Dim savetime As Long
savetime = GetTickCount
    Open App.Path & "\" & Text1.Text For Output As #1
    For i = 0 To 9999
        test = String(8 - Len(Hex(10000 - i)), "0") & Hex(10000 - i)
        For j = 1 To 10
            Print #1, test
        Next j
    Next i
    Close #1
MsgBox "耗时：" & GetTickCount - savetime & " 毫秒"
End Sub

Answer 25

速度和CPU,RAM有关吧。AMD Phenom II X6 1090T +12GB，估计可以跑10秒内。

Answer 26

To: SupermanKing
　　我先前把你的“快排”和删除的代码，跟我用Dictionary对象进行处理的代码，重新组织了一个测试程序。
生成数据是用的你的方式。只是我修改了一下，但生成结果是相同的。
得出的初步结论是：
　　“快排”在把有序数据打乱后，排序时间明显增加。对“乱序”进行排序的时间基本就是有序数据的2倍。
　　排序后进行筛选，数据多时占明显优势。因为排序时间基本就是正比关系，而Dictionary对象的时间，是指数关系，这个指数是略大于2的，也就是耗时比“平方关系”的时间还多。
下图是我的一次测试结果：你在26F的排序时间，那么多个“为０”的，我有点不明白。
是不是你的数据量不对啊？你38F的代码，看得出是1W条。

Answer 27

我几次测试的结果表明，3W数据的时候，两种方法速度相当。
数据量越多，排序筛选相对更快。
但数据少些，用Dictionary对象处理就要快些。把41F的图片，另存为 *.rar文件，打开就能解压我的测试源码。
里面也有编译好的 .exe程序。
有兴趣的可以试下。

Answer 28

即使相同数据量，运行结果也无法完全稳定。
因为跟CPU负荷状态有很大关系。
并且，GetTickCount()得到的时间，精度是很差的。

Answer 29

那个时间是我屏蔽了具体过程只做一个排序过程得到的时间，所以才会有那么多 "0"，而且当时用的是插入法，呵呵Private Sub Command3_Click()
    Dim ReadArray() As String
    Dim lngArraySize As Long
    Dim strTmp As String
    Dim fs As Integer
    Dim row As Long
    Dim i As Long
    Dim j As Long
    Dim index As Long
    Dim iscompositor As Boolean
    List1.Clear
Dim savetime As Long
savetime = GetTickCount
    '========== 把文本文件以行为单位读入字符串数组 ==========
    row = 0
    ReDim ReadArray(row)
    fs = FreeFile
    Open App.Path & "\" & Text1.Text For Input As #fs
    Do While Not EOF(fs)
    Line Input #fs, strTmp
    ReadArray(row) = strTmp
    row = row + 1
    ReDim Preserve ReadArray(row)
    Loop
    Close #fs
    lngArraySize = row - 1
    ReDim Preserve ReadArray(lngArraySize)
Dim readfiletime As Long
readfiletime = GetTickCount    '========== 对数组进行排序 ==========
    '冒泡法
    'Call compositor_ebullient(ReadArray)
Dim mpftime As Long
mpftime = GetTickCount
    '选择法
    'Call compositor_select(ReadArray)
Dim xzftime As Long
xzftime = GetTickCount
    '快速法
    Call compositor_quick(ReadArray, 0, lngArraySize)
Dim ksftime As Long
ksftime = GetTickCount
    '插入法
'    Call compositor_insert(ReadArray)
Dim crftime As Long
crftime = GetTickCount
    '希尔法
'    Call compositor_shell(ReadArray)
Dim xrftime As Long
xrftime = GetTickCount
    '========== 对数组进行除重 ==========
    '除重
    Call kill_repeated(ReadArray)
Dim ccftime As Long
ccftime = GetTickCount
    
Dim compositortime As Long
compositortime = GetTickCount
    '========== 将排序好的数组输出 ==========
    lngArraySize = UBound(ReadArray)
    For i = 0 To lngArraySize
        List1.AddItem ReadArray(i)
    Next i
Dim overtime As Long
overtime = GetTickCount
MsgBox "总耗时：" & overtime - savetime & " 毫秒" & vbCrLf & _
       "读文件：" & readfiletime - savetime & " 毫秒" & vbCrLf & _
       "冒泡法：" & mpftime - readfiletime & " 毫秒" & vbCrLf & _
       "选择法：" & xzftime - mpftime & " 毫秒" & vbCrLf & _
       "快速法：" & ksftime - xzftime & " 毫秒" & vbCrLf & _
       "插入法：" & crftime - ksftime & " 毫秒" & vbCrLf & _
       "希尔法：" & xrftime - crftime & " 毫秒" & vbCrLf & _
       "除重复：" & ccftime - xrftime & " 毫秒" & vbCrLf & _
       "加数据：" & overtime - compositortime & " 毫秒"
End Sub