VBGood网站全文搜索 Google

搜索VBGood全站网页(全文搜索)

VB爱好者乐园(VBGood)

 找回密码
 立即注册
搜索
123
返回列表 发新帖
楼主: 桂林初学者

[经验技巧] 求助讨论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

点评

机械的  发表于 2013-6-4 14:57
你这个是固态硬盘吧!  发表于 2013-5-28 11:49
38毫秒的路过 - -!  发表于 2013-5-28 07:53
回复 支持 反对

使用道具 举报

发表于 2013-5-29 07:17:46 | 显示全部楼层
  1. Private Sub Command1_Click()
  2.     Dim sBuf As String
  3.     Dim sTmp() As String, i As Long, s() As String
  4.    
  5.     Dim sItem As Variant, sKey As Variant
  6.     Dim f As Integer, t As Long
  7.     Dim n As Long
  8.    
  9.     t = timeGetTime
  10.    
  11.     f = FreeFile
  12.     Open App.Path & "\10万数据.txt" For Binary As f
  13.     sBuf = Space$(LOF(f))
  14.     Get f, , sBuf
  15.     Close f
  16.     sTmp = Split(sBuf, vbCrLf)
  17.    
  18.     Dtc.RemoveAll
  19.     'On Error Resume Next
  20.     For i = 0 To UBound(sTmp)
  21.         If Dtc.Exists(sTmp(i)) Then
  22.             n = Val(Dtc.Item(sTmp(i))) + 1
  23.             Dtc.Item(sTmp(i)) = n
  24.         Else
  25.             Dtc.Add sTmp(i), 1
  26.         End If
  27.     Next
  28.     'On Error GoTo 0
  29.     sItem = Dtc.Items
  30.     sKey = Dtc.Keys
  31.     For i = 0 To UBound(sItem)
  32.         sItem(i) = sKey(i) & "," & sItem(i)
  33.     Next
  34.     sBuf = Join$(sItem, vbCrLf)
  35.     If Dir(App.Path & "\异同部分1.txt") <> "" Then Kill App.Path & "\异同部分1.txt"
  36.     f = FreeFile
  37.     Open App.Path & "\异同部分1.txt" For Binary As f
  38.     Put f, , sBuf
  39.     Close f
  40.    
  41.     MsgBox timeGetTime - t, , "完成"
  42. End Sub
复制代码
附件就不传了 我这里测试10w数据是370ms
回复 支持 反对

使用道具 举报

发表于 2013-5-29 22:27:10 | 显示全部楼层
我倒是很想看看1亿数据行去重复的写法,

点评

需要多少内存才够?  发表于 2013-6-9 20:35
10^8必须分片,因为内存根本不够。。。  发表于 2013-6-3 20:59
回复 支持 反对

使用道具 举报

发表于 2013-6-3 21:58:18 | 显示全部楼层
1W:2W的
10W的统计稍后楼下。。。


  1. Private Declare Function timeGetTime Lib "winmm.dll" () As Long

  2. Sub Read(ByRef Path As String, ByRef Arr() As Long)
  3.     FileNum = FreeFile
  4.     Open Path For Binary As #FileNum
  5.     ReDim Buff(0 To LOF(FileNum)) As Byte
  6.     Get #FileNum, , Buff
  7.     Close #FileNum

  8.     Dim Size As Long, Pos As Long
  9.     Size = 16
  10.     ReDim Arr(0 To Size - 1)
  11.    
  12.     Dim i As Long, j As Long, k As Long
  13.     For i = 0 To UBound(Buff)
  14.         If Buff(i) >= 48 And Buff(i) <= 57 Then
  15.             j = i
  16.             k = 0
  17.             Do While Buff(j) >= 48 And Buff(j) <= 57
  18.                 k = k * 10 + Buff(j) - 48
  19.                 j = j + 1
  20.             Loop
  21.             
  22.             If Pos >= Size Then
  23.                 Size = Size * 2
  24.                 ReDim Preserve Arr(0 To Size - 1)
  25.             End If
  26.             
  27.             Arr(Pos) = k
  28.             Pos = Pos + 1
  29.             i = j
  30.         End If
  31.     Next
  32.    
  33.     ReDim Preserve Arr(0 To Pos - 1)
  34. End Sub

  35. Public Sub QuickSort(ByRef Arr() As Long, ByVal L As Long, ByVal R As Long)
  36.    
  37.         Dim i As Long, j As Long, x As Long, y As Long
  38.         i = L
  39.         j = R
  40.         x = Arr((L + R) \ 2)
  41.         Do While i <= j
  42.             Do While Arr(i) < x
  43.                 i = i + 1
  44.             Loop
  45.             Do While x < Arr(j)
  46.                 j = j - 1
  47.             Loop
  48.             If i <= j Then
  49.                 y = Arr(i)
  50.                 Arr(i) = Arr(j)
  51.                 Arr(j) = y
  52.                 i = i + 1
  53.                 j = j - 1
  54.             End If
  55.         Loop

  56.         If L < j Then Call QuickSort(Arr, L, j)
  57.         If i < R Then Call QuickSort(Arr, i, R)

  58. End Sub


  59. Private Sub Command4_Click()

  60.     Dim FileNum As Integer
  61.     Dim Buff() As Byte
  62.     Dim n As Long
  63.    
  64.     t = timeGetTime
  65.    
  66.    
  67.     Dim Arr1() As Long, Arr2() As Long
  68.     Call Read(Text1, Arr1)
  69.     Call Read(Text2, Arr2)
  70.    
  71.     Call QuickSort(Arr1, 0, UBound(Arr1))
  72.     Call QuickSort(Arr2, 0, UBound(Arr2))

  73.     ReDim Arr3(0 To UBound(Arr2)) As String
  74.     Dim Pos As Long
  75.     Dim i As Long, j As Long, k As Long
  76.     Do While i <= UBound(Arr1) Or j <= UBound(Arr2)
  77.         If i <= UBound(Arr1) Then
  78.             If j <= UBound(Arr2) Then
  79.                 If Arr2(j) < Arr1(i) Then
  80.                     Arr3(Pos) = Arr2(j)
  81.                     Pos = Pos + 1
  82.                     
  83.                     k = Arr2(j)
  84.                     Do While Arr2(j) = k
  85.                         j = j + 1
  86.                         If (j > UBound(Arr2)) Then Exit Do
  87.                     Loop
  88.                 ElseIf Arr2(j) = Arr1(i) Then
  89.                     k = Arr2(j)
  90.                     Do While Arr1(i) = k
  91.                         i = i + 1
  92.                         If (i > UBound(Arr1)) Then Exit Do
  93.                     Loop
  94.                     Do While Arr2(j) = k
  95.                         j = j + 1
  96.                         If (j > UBound(Arr2)) Then Exit Do
  97.                     Loop
  98.                 Else
  99.                     i = i + 1
  100.                 End If
  101.             Else
  102.                 i = i + 1
  103.             End If
  104.         Else
  105.             Arr3(Pos) = Arr2(j)
  106.             Pos = Pos + 1
  107.             
  108.             k = Arr2(j)
  109.             Do While Arr2(j) = k
  110.                 j = j + 1
  111.                 If (j > UBound(Arr2)) Then Exit Do
  112.             Loop
  113.         End If
  114.     Loop
  115.    
  116.     ReDim Preserve Arr3(0 To Pos - 1)
  117.     Open App.Path & "\异同部分_xjm.txt" For Output As #1
  118.     Print #1, Join$(Arr3, vbCrLf)
  119.     Close #1

  120.     MsgBox timeGetTime - t, , "异同条目:" & n
  121. End Sub


  122. Private Sub Form_Load()
  123.     Text1 = Replace$(App.Path & "\\10000条.txt", "\", "")
  124.     Text2 = Replace$(App.Path & "\\20000条.txt", "\", "")
  125. End Sub

复制代码
回复 支持 反对

使用道具 举报

发表于 2013-6-3 22:09:43 | 显示全部楼层
统计的
如果要保持格式的话,调下format


  1. Private Declare Function timeGetTime Lib "winmm.dll" () As Long

  2. Sub Read(ByRef Path As String, ByRef Arr() As Long)
  3.     FileNum = FreeFile
  4.     Open Path For Binary As #FileNum
  5.     ReDim Buff(0 To LOF(FileNum)) As Byte
  6.     Get #FileNum, , Buff
  7.     Close #FileNum

  8.     Dim Size As Long, Pos As Long
  9.     Size = 16
  10.     ReDim Arr(0 To Size - 1)
  11.    
  12.     Dim i As Long, j As Long, k As Long
  13.     For i = 0 To UBound(Buff)
  14.         If Buff(i) >= 48 And Buff(i) <= 57 Then
  15.             j = i
  16.             k = 0
  17.             Do While Buff(j) >= 48 And Buff(j) <= 57
  18.                 k = k * 10 + Buff(j) - 48
  19.                 j = j + 1
  20.             Loop
  21.             
  22.             If Pos >= Size Then
  23.                 Size = Size * 2
  24.                 ReDim Preserve Arr(0 To Size - 1)
  25.             End If
  26.             
  27.             Arr(Pos) = k
  28.             Pos = Pos + 1
  29.             i = j
  30.         End If
  31.     Next
  32.    
  33.     ReDim Preserve Arr(0 To Pos - 1)
  34. End Sub

  35. Public Sub QuickSort(ByRef Arr() As Long, ByVal L As Long, ByVal R As Long)
  36.    
  37.         Dim i As Long, j As Long, x As Long, y As Long
  38.         i = L
  39.         j = R
  40.         x = Arr((L + R) \ 2)
  41.         Do While i <= j
  42.             Do While Arr(i) < x
  43.                 i = i + 1
  44.             Loop
  45.             Do While x < Arr(j)
  46.                 j = j - 1
  47.             Loop
  48.             If i <= j Then
  49.                 y = Arr(i)
  50.                 Arr(i) = Arr(j)
  51.                 Arr(j) = y
  52.                 i = i + 1
  53.                 j = j - 1
  54.             End If
  55.         Loop

  56.         If L < j Then Call QuickSort(Arr, L, j)
  57.         If i < R Then Call QuickSort(Arr, i, R)

  58. End Sub


  59. Private Sub Command4_Click()

  60.     Dim FileNum As Integer
  61.     Dim Buff() As Byte
  62.     Dim n As Long
  63.    
  64.     t = timeGetTime
  65.    
  66.    
  67.     Dim Arr1() As Long
  68.     Call Read(Text1, Arr1)
  69.     Call QuickSort(Arr1, 0, UBound(Arr1))

  70.     ReDim Arr2(0 To UBound(Arr1)) As String
  71.     Dim Pos As Long

  72.     Dim i As Long, j As Long, k As Long
  73.     For i = 0 To UBound(Arr1)
  74.         k = 1
  75.         For j = i + 1 To UBound(Arr1)
  76.             If Arr1(j) > Arr1(i) Then Exit For
  77.             k = k + 1
  78.         Next
  79.         
  80.         Arr2(Pos) = Arr1(i) & "," & k
  81.         Pos = Pos + 1
  82.         i = j - 1
  83.     Next

  84.     ReDim Preserve Arr2(0 To Pos - 1)
  85.     Open App.Path & "\统计.txt" For Output As #1
  86.     Print #1, Join$(Arr2, vbCrLf)
  87.     Close #1

  88.     MsgBox timeGetTime - t, , "异同条目:" & n
  89. End Sub


  90. Private Sub Form_Load()
  91.     Text1 = Replace$(App.Path & "\\10万数据.txt", "\", "")
  92. End Sub

复制代码

点评

我说了方法的啊...format  发表于 2013-6-4 09:40
剑魔大人的算法果然很快 但如何保持数据格式不变(不要影响速度) 还有如果是字符串而不是数字这方法还行的通么 求解答  发表于 2013-6-4 02:21
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

文字版|手机版|小黑屋|VBGood  

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

VB爱好者乐园(VBGood)
快速回复 返回顶部 返回列表