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

liu-aguang

ak47ok 发表于 2014-9-15 16:18
惭愧、在实际应用中有一种情况，自己半天还是没有解决，只好硬着头皮来劳烦老师，增加了返回一列数据的 ...

1. Sub test()
   
2.     '本代码以第一行左右两部份编码定位,要求:
   
3.     '左边开始A1;以最后一个编码结束,最后一个编码紧接着的单元格保持为空;
   
4.     '右边开始AJ1;以"另一值"单元格"结束,"另一值"与编码之间不留空格."另一值"的名称随意.
   
5.     Dim arr, d, i%, j%, brr, aCol%, bCol%, k$, c As Range, c1 As Range
   
6.     Sheets("sheet1").Activate
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.     Set c = Columns("aj").Find(Range("a2"), SearchDirection:=1)
   
9.     Set c1 = Columns("aj").Find(Range("a2"), SearchDirection:=2)
   
10.     arr = Range(Range("b1").End(xlToRight).Offset(, 1), Range("a65536").End(xlUp))
    
11.     brr = Range(c, Cells(c1.Row, Range("ak1").End(xlToRight).Column))
    
12.     k = Range("ak1").End(xlToRight): arr(1, UBound(arr, 2)) = k
    
13.     For i = 1 To UBound(brr)
    
14.         For j = 3 To UBound(brr, 2)
    
15.             d(brr(i, 2) & arr(1, j - 1)) = brr(i, j)
    
16.         Next
    
17.     Next
    
18.     For i = 10 To UBound(arr)
    
19.         For j = 2 To UBound(arr, 2) - 1
    
20.             If InStr(arr(1, j), "反") = 0 Then
    
21.                 arr(i, j) = IIf(d(arr(i, 1) & arr(1, j)) > arr(2, j), 1, 0)
    
22.             Else
    
23.                 arr(i, j) = IIf(d(arr(i, 1) & arr(1, j)) < arr(2, j), 1, 0)
    
24.             End If
    
25.         Next
    
26.         arr(i, j) = d(arr(i, 1) & k)
    
27.     Next
    
28.     arr(1, UBound(arr, 2)) = ""
    
29.     Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
30. End Sub
    

复制代码

liu-aguang

用VBA直接计算3v1.rar (434.68 KB, 下载次数: 12)

2014-9-15 18:26 上传

点击文件名下载附件

ak47ok

liu-aguang 发表于 2014-9-15 18:22

就差这一点：
我想在数据编码没有31个时、另值的结果都是在AG列出现，因为想将另一值固定在BQ列，这样要如何调整。劳烦老师再费神了，谢谢！

liu-aguang

ak47ok 发表于 2014-9-15 20:26
就差这一点：
我想在数据编码没有31个时、另值的结果都是在AG列出现，因为想将另一值固定 ...

一次把问题想完再求助.

1. Sub test()
   
2.     Dim arr, d, i%, j%, brr, aCol%, bCol%, k$, 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("ag1"), Range("a65536").End(xlUp))
   
8.     brr = Range(c, Cells(c1.Row, 69))
   
9.     k = Range("bq1")
   
10.     na = Application.CountA(Range(Range("a1"), Range("ag1")))
    
11.     For i = 1 To UBound(brr)
    
12.         For j = 3 To na + 1
    
13.             d(brr(i, 2) & arr(1, j - 1)) = brr(i, j)
    
14.         Next
    
15.         d(brr(i, 2) & k) = brr(i, 34)
    
16.     Next
    
17.     For i = 10 To UBound(arr)
    
18.         For j = 2 To na
    
19.             If InStr(arr(1, j), "反") = 0 Then
    
20.                 arr(i, j) = IIf(d(arr(i, 1) & arr(1, j)) > arr(2, j), 1, 0)
    
21.             Else
    
22.                 arr(i, j) = IIf(d(arr(i, 1) & arr(1, j)) < arr(2, j), 1, 0)
    
23.             End If
    
24.         Next
    
25.         arr(i, 33) = d(arr(i, 1) & k)
    
26.     Next
    
27.     Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
28. End Sub
    

复制代码

ak47ok

liu-aguang 发表于 2014-9-15 18:22

经核对、发现有点小问题，还要劳烦老师查看下代码：
就是比较的数据，如在黄色的名称中的“K4”在红字区域是没有的，但本楼的代码运算后它会有返回数值、而K4的“另值”返回是正确的（为空）

谢谢！

liu-aguang

ak47ok 发表于 2014-9-16 09:44
经核对、发现有点小问题，还要劳烦老师查看下代码：
就是比较的数据，如在黄色的名称中的“K4”在红字区 ...

1. Sub test()
   
2.     Dim arr, d, i%, j%, brr, s$, k$, c As Range, c1 As Range
   
3.     Sheets("sheet1").Activate
   
4.     Range(Range("a65536").End(xlUp), Range("ag1").End(xlDown)).SpecialCells(2, 1).ClearContents
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Set c = Columns("aj").Find(Range("a2"), SearchDirection:=1)
   
7.     Set c1 = Columns("aj").Find(Range("a2"), SearchDirection:=2)
   
8.     arr = Range(Range("ag1"), Range("a65536").End(xlUp))
   
9.     brr = Range(c, Cells(c1.Row, 69))
   
10.     k = Range("bq1")
    
11.     na = Application.CountA(Range(Range("a1"), Range("ag1")))
    
12.     For i = 1 To UBound(brr)
    
13.         For j = 3 To na + 1
    
14.             d(brr(i, 2) & arr(1, j - 1)) = brr(i, j)
    
15.         Next
    
16.         d(brr(i, 2) & k) = brr(i, 34)
    
17.     Next
    
18.     For i = 10 To UBound(arr)
    
19.         For j = 2 To na
    
20.             s = arr(i, 1) & arr(1, j)
    
21.             If d.exists(s) Then
    
22.             If InStr(arr(1, j), "反") = 0 Then
    
23.                 arr(i, j) = IIf(d(s) > arr(2, j), 1, 0)
    
24.             Else
    
25.                 arr(i, j) = IIf(d(s) < arr(2, j), 1, 0)
    
26.             End If
    
27.             End If
    
28.         Next
    
29.         arr(i, 33) = d(arr(i, 1) & k)
    
30.     Next
    
31.     Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
32. End Sub
    

复制代码

ak47ok

liu-aguang 发表于 2014-9-16 10:54

着实的学习了下，难度不小，这么多数组、运算完一步到位，要多好的空间思维啊！
看来这些就此打住了、其他的都小范围的函数运算仍保留excel函数运算好了。

等自己有一定VBA数组基础后再弄了。现在了提速不少了、这一步提速0.8秒：几套循环下来：169*374*0.8、省了14小时。

再次感谢liu-aguang 老师不厌其烦的指导、真心感谢！

ak47ok

有所体会：
在用excel函数时想将公式写得通用些、使其在更多范围使用都正确，这样将公式写得超长，其实用VBA代码来解决还是很简单的，
但目前我还不会。

象现在我保用很多类似的公式：
=MODE(INDIRECT("Sheet1!"&SUBSTITUTE(ADDRESS(1,MIN(COLUMN()),4),1,)&MATCH($A7,Sheet1!$F$2:$F$409,)&":"&SUBSTITUTE(ADDRESS(1,MIN(COLUMN()),4),1,)&(MATCH($A7,Sheet1!$F$2:$F$409,)+COUNTIF(Sheet1!$F:$F,$A7))))

ak47ok

liu-aguang 发表于 2014-9-16 10:54

得到老师的代码后、它一直在日以继夜、忙碌的运行着。三天没有关电脑了。

但还是遇到状况：当迅雷软件运行时、就会有出错提示：
这个问题能解决吗？

谢谢！

ak47ok

每次都是这样，
出错提示在这句：
brr = Range(c, Cells(c1.Row, 69))