Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 4270|回复: 27

[已解决]求助各位大神!!程序 运行提速(有新要求改动)

[复制链接]
发表于 2015-12-3 10:39 | 显示全部楼层 |阅读模式
本帖最后由 啦啦游游 于 2015-12-4 14:38 编辑

如附件程序(附件在2楼)~~有什么可以办法使它运行起来更快的吗~~求各位大神帮忙呀~~~


具体要求在6楼~~
麻烦大家啦~~~
最佳答案
2015-12-4 14:08
多点数据测试了一下,结果和你的结果相同(左边是按钮结果,右边是你原代码双击结果)
 楼主| 发表于 2015-12-3 10:50 | 显示全部楼层
程序附件已传~!!求帮忙{:091:}

test2.zip

29.99 KB, 下载次数: 5

回复

使用道具 举报

发表于 2015-12-3 11:39 | 显示全部楼层
没作调试,仅从代码简化的角度改了一下:
  1. Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  2. Dim Sh As Worksheet
  3. Cells.Select
  4. Selection.ClearContents
  5. Set Sh = Sheet2
  6. Sh.Cells.Interior.ColorIndex = 0
  7. 'clear sheet

  8. Sh.Cells(1, 1) = "Material ID"
  9. Sh.Cells(1, 3) = "Result"

  10. With Sheet1
  11.     hv = .[a1].End(xlDown).Row
  12.     sv = .[a1].End(xlToRight).Column
  13. 'find the coordinate of the last horizontal(hv) and vertical line(sv)
  14.     .Cells(1, 2).Resize(1, sv - 1).Interior.ColorIndex = 0
  15. 'clear the sheet1's cells'color

  16. Sh.[a2].Resize(hv - 1).Value = .[a2].Resize(hv - 1).Value
  17. 'creat the final form

  18. cv = .Cells(3, .Columns.Count).End(xlToLeft).Column

  19. For n = 2 To sv
  20.     For m = 8 To cv
  21.         If .Cells(1, n) = .Cells(3, m) Then .Cells(1, n).Interior.ColorIndex = 38
  22.     Next
  23. Next

  24. 'mark with color of the parameters'cell which we don't compare,here for example i choose weight would not be compared

  25. blank = 0
  26. For n = 2 To sv
  27.     If .Cells(1, n).Interior.ColorIndex = 38 Then blank = blank + 1
  28. Next
  29. 'blank is the number of the parameter which we don't compare

  30. xxx = .Cells(2, "h"): mystr = " empties more than " & xxx
  31. For i = 2 To hv
  32.     o = 0
  33.     emp = 0
  34.     For n = 2 To sv
  35.         If .Cells(i, n) = "" And .Cells(1, n).Interior.ColorIndex <> 38 Then
  36.             emp = emp + 1
  37.             If emp > xxx Then Sh.Cells(i, 3) = mystr
  38.         End If
  39.     Next n
  40. Next i
  41. 'compare each material's empties with the limit value
  42. 'when the number greater than limit value,the material won't be compared with others


  43. For i = 2 To hv - 1
  44.     If Sh.Cells(i, 3) <> mystr Then
  45.         o = 0
  46.         For j = i + 1 To hv
  47.             If Sh.Cells(j, 3) <> mystr Then
  48.                 p = 0
  49.                 For n = 2 To sv
  50.                     If .Cells(1, n).Interior.ColorIndex <> 38 Then
  51.                         If .Cells(i, n) <> .Cells(j, n) And .Cells(i, n) <> "" And .Cells(j, n) <> "" Then
  52.                             com = 0
  53.                             Exit For
  54.                         Else
  55.                             com = 1
  56.                             If .Cells(i, n) = "" Or .Cells(j, n) = "" Then p = p + 1
  57.                         'get the number of blanks
  58.                         End If
  59.                     End If
  60.                 Next
  61.             'find the possibility of if two materials the same one are
  62.             
  63.                 If com = 1 Then
  64.                     Sh.Cells(i, 3 + o) = .Cells(j, 1) & "(" & p & "/" & sv - 1 - blank & ")"
  65.                     o = o + 1
  66.                 End If
  67.             End If
  68.         Next j
  69.     End If
  70. Next i
  71. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2015-12-3 13:07 | 显示全部楼层
本帖最后由 啦啦游游 于 2015-12-3 13:09 编辑
grf1973 发表于 2015-12-3 11:39
没作调试,仅从代码简化的角度改了一下:


谢谢~~

那能再帮忙看看怎样能把运行速度提上去吗~?
代码复杂点也没关系,主要是想要当数据量很大的时候运行速度能快一点~~
之前试过一万个material的话大概要3个小时才能运行出来。。。。。。


感觉好像是几个循环嵌套的太多,所以很慢
不知道是不是这个原因
回复

使用道具 举报

发表于 2015-12-3 13:09 | 显示全部楼层
你干脆提要求得了,根据要求重编。
回复

使用道具 举报

 楼主| 发表于 2015-12-3 16:09 | 显示全部楼层
grf1973 发表于 2015-12-3 13:09
你干脆提要求得了,根据要求重编。

附件的sheet1中是已知数据,两两材料之间需要依次比较各参数是否相同,判断两者是否可能为相同物品(空白处可能相等),若可能相同就得出误差率a/b(a为空白参数量,b为参与比较的参数量)。
但是同时有的参量不参与比较,或是当一个材料的空白参数超过限定值那这个材料做无效处理不与其他材料进行比较。
结果写在sheet2中(如1001与1002,1003相同,就写做1001  1002(a/b)1003(a/b))


现在这个是只有1001到1006几个材料需要比较,但是实际运用的时候可能有十万个或者更多,所以需要能运行大量数据的程序

谢谢啦~~
回复

使用道具 举报

发表于 2015-12-4 11:26 | 显示全部楼层
你上个几十组数据,然后模拟一下结果,这样才可着手调试。
回复

使用道具 举报

 楼主| 发表于 2015-12-4 13:10 | 显示全部楼层
grf1973 发表于 2015-12-4 11:26
你上个几十组数据,然后模拟一下结果,这样才可着手调试。

附件sheet1的那些数据直接复制粘贴很多行就行~~
那些数据本来就是随意设的~
回复

使用道具 举报

发表于 2015-12-4 14:02 | 显示全部楼层
试试这个。
  1. Sub 对比()
  2.     With Sheet1
  3.         arr = .[a1].CurrentRegion
  4.         emp = .[H2]    '允许的空值
  5.         nc = 2       '不比较的列,此例中Color列,为第2列
  6.         imf = " empties more than " & emp
  7.         b = UBound(arr, 2) - 1      '参与比较的参数量
  8.         If nc <= UBound(arr) And nc > 1 Then b = b - 1  '如果有不比较的量,则参数量减1
  9.     End With
  10.    
  11.     ReDim brr(1 To UBound(arr), 1 To 2)   '结果数组
  12.     brr(1, 1) = "Material ID": brr(1, 2) = " Result"
  13.     Set d = CreateObject("scripting.dictionary")         '保留符合条件的ID
  14.     Set d2 = CreateObject("scripting.dictionary")        '保留各ID空值个数
  15.    
  16.     '第一步:先把符合条件的行选出来,不符合条件的直接显示提示信息
  17.     For i = 2 To UBound(arr)
  18.         x = arr(i, 1)
  19.         brr(i, 1) = x
  20.         For j = 2 To UBound(arr, 2)
  21.             If j <> nc Then    '去掉不比较的列
  22.                 If Len(arr(i, j)) = 0 Then d2(x) = d2(x) + 1     '空格数
  23.                 If d2(x) > emp Then brr(i, 2) = imf: Exit For
  24.             End If
  25.         Next
  26.         If d2(x) <= emp Then d(x) = i
  27.     Next
  28.    
  29.     '第二步:符合条件各行对比,可能相同的显示筛选结果
  30.     dk = d.items          '保留符合条件的行
  31.     Dim IsEq As Boolean    '判断两行是否可能相同
  32.     For i = 0 To UBound(dk)
  33.         p = dk(i): x = arr(p, 1)
  34.         For k = i + 1 To UBound(dk)
  35.             q = dk(k): y = arr(q, 1)
  36.             IsEq = True
  37.             For j = 2 To UBound(arr, 2)
  38.                 If j <> nc Then    '去掉不比较的列
  39.                     If arr(p, j) <> "" And arr(q, j) <> "" And arr(p, j) <> arr(q, j) Then IsEq = False: Exit For     '两行对应列均非空,值不同,则两行不可能相同
  40.                 End If
  41.             Next
  42.             If IsEq = True Then brr(p, 2) = brr(p, 2) & "," & y & "(" & d2(x) + d2(y) & "/" & b & ")"
  43.         Next
  44.         If Len(brr(p, 2)) >= 2 Then brr(p, 2) = Mid(brr(p, 2), 2)
  45.     Next
  46.    
  47.     '第三步:最终结果显示
  48.     Sheet2.[a1].Resize(UBound(brr), 2) = brr
  49. End Sub
复制代码

test2.rar

37.81 KB, 下载次数: 0

回复

使用道具 举报

发表于 2015-12-4 14:04 | 显示全部楼层
第32句应该是For i = 0 To UBound(dk)-1
回复

使用道具 举报

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

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-28 17:44 , Processed in 0.688967 second(s), 13 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表