## 用户名 Email 自动登录 找回密码 密码 立即注册
 搜索

# [经验技巧] 求助讨论10万个以上数据对比10万个数据来个厉害的！~ 发表于 2013-5-27 20:25:33 | 显示全部楼层
 既然你这么期待 我也动动手吧 我这里测试结果是加载到筛选输出完成50毫秒解决

x

### 点评

109-203  发表于 2013-5-29 22:47 楼主| 发表于 2013-5-27 22:28:54 | 显示全部楼层
 本帖最后由 桂林初学者 于 2013-5-28 17:29 编辑 startbin321 发表于 2013-5-27 20:25 既然你这么期待 我也动动手吧 我这里测试结果是加载到筛选输出完成50毫秒解决 50毫秒太强大了！ 你那电脑速度真快，我的要150左右，快的时候80多，不稳定！ 这个是1万比2万 下面生成了个10万数据，请教怎么才能快速排列出出现过几次！并输出！ 我的方法效率太低了！请教大神指点下！

x

### 点评

38毫秒的路过 - -！  发表于 2013-5-28 07:53 发表于 2013-5-29 07:17:46 | 显示全部楼层
 Private Sub Command1_Click()     Dim sBuf As String     Dim sTmp() As String, i As Long, s() As String         Dim sItem As Variant, sKey As Variant     Dim f As Integer, t As Long     Dim n As Long         t = timeGetTime         f = FreeFile     Open App.Path & "\10万数据.txt" For Binary As f     sBuf = Space\$(LOF(f))     Get f, , sBuf     Close f     sTmp = Split(sBuf, vbCrLf)         Dtc.RemoveAll     'On Error Resume Next     For i = 0 To UBound(sTmp)         If Dtc.Exists(sTmp(i)) Then             n = Val(Dtc.Item(sTmp(i))) + 1             Dtc.Item(sTmp(i)) = n         Else             Dtc.Add sTmp(i), 1         End If     Next     'On Error GoTo 0     sItem = Dtc.Items     sKey = Dtc.Keys     For i = 0 To UBound(sItem)         sItem(i) = sKey(i) & "," & sItem(i)     Next     sBuf = Join\$(sItem, vbCrLf)     If Dir(App.Path & "\异同部分1.txt") <> "" Then Kill App.Path & "\异同部分1.txt"     f = FreeFile     Open App.Path & "\异同部分1.txt" For Binary As f     Put f, , sBuf     Close f         MsgBox timeGetTime - t, , "完成" End Sub复制代码附件就不传了 我这里测试10w数据是370ms 发表于 2013-5-29 22:27:10 | 显示全部楼层
 我倒是很想看看1亿数据行去重复的写法，

### 点评

10^8必须分片，因为内存根本不够。。。  发表于 2013-6-3 20:59 发表于 2013-6-3 21:58:18 | 显示全部楼层
 1W:2W的 10W的统计稍后楼下。。。 Private Declare Function timeGetTime Lib "winmm.dll" () As Long Sub Read(ByRef Path As String, ByRef Arr() As Long)     FileNum = FreeFile     Open Path For Binary As #FileNum     ReDim Buff(0 To LOF(FileNum)) As Byte     Get #FileNum, , Buff     Close #FileNum     Dim Size As Long, Pos As Long     Size = 16     ReDim Arr(0 To Size - 1)         Dim i As Long, j As Long, k As Long     For i = 0 To UBound(Buff)         If Buff(i) >= 48 And Buff(i) <= 57 Then             j = i             k = 0             Do While Buff(j) >= 48 And Buff(j) <= 57                 k = k * 10 + Buff(j) - 48                 j = j + 1             Loop                          If Pos >= Size Then                 Size = Size * 2                 ReDim Preserve Arr(0 To Size - 1)             End If                          Arr(Pos) = k             Pos = Pos + 1             i = j         End If     Next         ReDim Preserve Arr(0 To Pos - 1) End Sub Public Sub QuickSort(ByRef Arr() As Long, ByVal L As Long, ByVal R As Long)             Dim i As Long, j As Long, x As Long, y As Long         i = L         j = R         x = Arr((L + R) \ 2)         Do While i <= j             Do While Arr(i) < x                 i = i + 1             Loop             Do While x < Arr(j)                 j = j - 1             Loop             If i <= j Then                 y = Arr(i)                 Arr(i) = Arr(j)                 Arr(j) = y                 i = i + 1                 j = j - 1             End If         Loop         If L < j Then Call QuickSort(Arr, L, j)         If i < R Then Call QuickSort(Arr, i, R) End Sub Private Sub Command4_Click()     Dim FileNum As Integer     Dim Buff() As Byte     Dim n As Long         t = timeGetTime             Dim Arr1() As Long, Arr2() As Long     Call Read(Text1, Arr1)     Call Read(Text2, Arr2)         Call QuickSort(Arr1, 0, UBound(Arr1))     Call QuickSort(Arr2, 0, UBound(Arr2))     ReDim Arr3(0 To UBound(Arr2)) As String     Dim Pos As Long     Dim i As Long, j As Long, k As Long     Do While i <= UBound(Arr1) Or j <= UBound(Arr2)         If i <= UBound(Arr1) Then             If j <= UBound(Arr2) Then                 If Arr2(j) < Arr1(i) Then                     Arr3(Pos) = Arr2(j)                     Pos = Pos + 1                                          k = Arr2(j)                     Do While Arr2(j) = k                         j = j + 1                         If (j > UBound(Arr2)) Then Exit Do                     Loop                 ElseIf Arr2(j) = Arr1(i) Then                     k = Arr2(j)                     Do While Arr1(i) = k                         i = i + 1                         If (i > UBound(Arr1)) Then Exit Do                     Loop                     Do While Arr2(j) = k                         j = j + 1                         If (j > UBound(Arr2)) Then Exit Do                     Loop                 Else                     i = i + 1                 End If             Else                 i = i + 1             End If         Else             Arr3(Pos) = Arr2(j)             Pos = Pos + 1                          k = Arr2(j)             Do While Arr2(j) = k                 j = j + 1                 If (j > UBound(Arr2)) Then Exit Do             Loop         End If     Loop         ReDim Preserve Arr3(0 To Pos - 1)     Open App.Path & "\异同部分_xjm.txt" For Output As #1     Print #1, Join\$(Arr3, vbCrLf)     Close #1     MsgBox timeGetTime - t, , "异同条目：" & n End Sub Private Sub Form_Load()     Text1 = Replace\$(App.Path & "\\10000条.txt", "\", "")     Text2 = Replace\$(App.Path & "\\20000条.txt", "\", "") End Sub 复制代码 发表于 2013-6-3 22:09:43 | 显示全部楼层
 统计的 如果要保持格式的话，调下format Private Declare Function timeGetTime Lib "winmm.dll" () As Long Sub Read(ByRef Path As String, ByRef Arr() As Long)     FileNum = FreeFile     Open Path For Binary As #FileNum     ReDim Buff(0 To LOF(FileNum)) As Byte     Get #FileNum, , Buff     Close #FileNum     Dim Size As Long, Pos As Long     Size = 16     ReDim Arr(0 To Size - 1)         Dim i As Long, j As Long, k As Long     For i = 0 To UBound(Buff)         If Buff(i) >= 48 And Buff(i) <= 57 Then             j = i             k = 0             Do While Buff(j) >= 48 And Buff(j) <= 57                 k = k * 10 + Buff(j) - 48                 j = j + 1             Loop                          If Pos >= Size Then                 Size = Size * 2                 ReDim Preserve Arr(0 To Size - 1)             End If                          Arr(Pos) = k             Pos = Pos + 1             i = j         End If     Next         ReDim Preserve Arr(0 To Pos - 1) End Sub Public Sub QuickSort(ByRef Arr() As Long, ByVal L As Long, ByVal R As Long)             Dim i As Long, j As Long, x As Long, y As Long         i = L         j = R         x = Arr((L + R) \ 2)         Do While i <= j             Do While Arr(i) < x                 i = i + 1             Loop             Do While x < Arr(j)                 j = j - 1             Loop             If i <= j Then                 y = Arr(i)                 Arr(i) = Arr(j)                 Arr(j) = y                 i = i + 1                 j = j - 1             End If         Loop         If L < j Then Call QuickSort(Arr, L, j)         If i < R Then Call QuickSort(Arr, i, R) End Sub Private Sub Command4_Click()     Dim FileNum As Integer     Dim Buff() As Byte     Dim n As Long         t = timeGetTime             Dim Arr1() As Long     Call Read(Text1, Arr1)     Call QuickSort(Arr1, 0, UBound(Arr1))     ReDim Arr2(0 To UBound(Arr1)) As String     Dim Pos As Long     Dim i As Long, j As Long, k As Long     For i = 0 To UBound(Arr1)         k = 1         For j = i + 1 To UBound(Arr1)             If Arr1(j) > Arr1(i) Then Exit For             k = k + 1         Next                  Arr2(Pos) = Arr1(i) & "," & k         Pos = Pos + 1         i = j - 1     Next     ReDim Preserve Arr2(0 To Pos - 1)     Open App.Path & "\统计.txt" For Output As #1     Print #1, Join\$(Arr2, vbCrLf)     Close #1     MsgBox timeGetTime - t, , "异同条目：" & n End Sub Private Sub Form_Load()     Text1 = Replace\$(App.Path & "\\10万数据.txt", "\", "") End Sub 复制代码

### 点评

 您需要登录后才可以回帖 登录 | 立即注册 本版积分规则 回帖并转播 回帖后跳转到最后一页

GMT+8, 2022-7-4 23:05

VB爱好者乐园(VBGood)