88万行的数据运算：如何编写代码来代替excel函数的运算，谢谢！

liu-aguang

ak47ok 发表于 2014-9-13 11:19
感谢关注、已补充说明，麻烦老师费神。谢谢！

看是不是明白了你的意思:

1. Sub test()
   
2.     Dim arr, d, i%, j%, ar, c As Range, c1 As Range
   
3.     Sheets("sheet1").Activate
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set c = Columns("m").Find(Range("a2"), SearchDirection:=1)
   
6.     Set c1 = Columns("m").Find(Range("a2"), SearchDirection:=2)
   
7.     arr = Range(c.Offset(, 1), c1.Offset(, 1).Resize(, 9))
   
8.     ar = Array("", "", "甲", "乙", "丙", "丁", "戊", "己", "庚", "辛")
   
9.     For i = 1 To UBound(arr)
   
10.         For j = 2 To UBound(arr, 2)
    
11.             d(arr(i, 1) & ar(j)) = arr(i, j)
    
12.         Next
    
13.     Next
    
14.     arr = Range(Range("a1"), Range("a65536").End(xlUp)).Resize(, 9)
    
15.     For i = 10 To UBound(arr)
    
16.         For j = 2 To UBound(arr, 2)
    
17.             If d(arr(i, 1) & arr(1, j)) > arr(2, j) Then
    
18.             arr(i, j) = IIf(arr(1, j) = "丙" Or arr(1, j) = "辛", 0, 1)
    
19.             Else    '相等也按下行处理
    
20.             arr(i, j) = IIf(arr(1, j) = "丙" Or arr(1, j) = "辛", 1, 0)
    
21.             End If
    
22.         Next
    
23.     Next
    
24.     Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
25. End Sub
    

复制代码

ak47ok

liulang0808 发表于 2014-9-13 13:43
Sub 按钮1_Click()
    Application.ScreenUpdating = False
    Range("b10:i20").ClearContents

学习了，正解！，这就是VBA高手的基本功，谢谢！

ak47ok

liu-aguang 发表于 2014-9-13 16:18
看是不是明白了你的意思:

正解！好功夫，谢谢！

ak47ok

liu-aguang老师的代码运算飞快，这样大数据运算体现了快感！

用代码运算自身运行快速外，还省却了为去除excel函数运算后的复制、粘贴数值、去除无效值等，快多了，

运算从88万行数据匹配3000行数据用时 0.93 秒！爽
但代码还是有很多不明白的地方，好好学习，再将感谢！

ak47ok

liu-aguang 发表于 2014-9-13 16:18
看是不是明白了你的意思:

为减少在实际运用中改代码的麻烦
将条件设简单的点，给出的条件：
将两处的各个数据编码的次序设为相同，看看如何简化代码、再将劳烦老师了，谢谢！

liu-aguang

ak47ok 发表于 2014-9-14 21:57
为减少在实际运用中改代码的麻烦
将条件设简单的点，给出的条件：
将两处的各个数据编码的次序设为相同 ...

1. Sub test()   '第一行两部分黄色编码个数,可自由增减,但要保持一致,但每部分的单元格之间不留空格.两边的开始单元格不能变(B1/AK1).
   
2.     Dim arr, d, i%, j%, brr, c As Range, c1 As Range
   
3.     Sheets("sheet1").Activate
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set c = Columns("aj").Find(Range("a2"), SearchDirection:=1)
   
6.     Set c1 = Columns("aj").Find(Range("a2"), SearchDirection:=2)
   
7.     arr = Range(Range("b1").End(xlToRight), Range("a65536").End(xlUp))
   
8.     brr = Range(c, Cells(c1.Row, Range("ak1").End(xlToRight).Column))
   
9.     For i = 1 To UBound(brr)
   
10.         For j = 3 To UBound(brr, 2)
    
11.             d(brr(i, 2) & arr(1, j - 1)) = brr(i, j)
    
12.         Next
    
13.     Next
    
14.         For i = 10 To UBound(arr)
    
15.         For j = 2 To UBound(arr, 2)
    
16.             If InStr(arr(1, j), "反") = 0 Then
    
17.                 arr(i, j) = IIf(d(arr(i, 1) & arr(1, j)) > arr(2, j), 1, 0)
    
18.             Else
    
19.                 arr(i, j) = IIf(d(arr(i, 1) & arr(1, j)) < arr(2, j), 1, 0)
    
20.             End If
    
21.         Next
    
22.     Next
    
23.     Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
24. End Sub
    

复制代码

ak47ok

向liu-aguang老师致敬！！我的第二个附件设计已考虑了这些问题，再次感谢liu-aguang老师！

ak47ok

手机上论坛，不能评分？uc浏览器

ak47ok

liu-aguang 发表于 2014-9-14 23:05

赞一个！
第一次得到liu-aguang 老师的帮助就已知其功力深厚。
liu-aguang 老师的技术和古道热肠真有赵版当年的风范，老师继续努力、祝您早日能取得Microsoft MVP！
当年我也是这样预祝赵版的。

ak47ok

liu-aguang 发表于 2014-9-14 23:05

惭愧、在实际应用中有一种情况，自己半天还是没有解决，只好硬着头皮来劳烦老师，增加了返回一列数据的问题，麻烦老师指导谢谢！！