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

liu-aguang

ak47ok 发表于 2014-9-17 18:49
每次都是这样，
出错提示在这句：
brr = Range(c, Cells(c1.Row, 69))

哪有那么多数据需要处理,我也不知道错误原因.用下列代码试试:

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

复制代码

liu-aguang

应该与迅雷无关,可能是A2单元格内的数据没有找到.下列的代码增加了检测语句,如果数据没有找到或空,代码会有错误提示.

1. Sub test()
   
2.     Dim arr, d, i%, j%, brr, s$, k$, c As Range, c1 As Range
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     With Sheets("sheet1")
   
5.         If Len(.Cells(2, 1)) = 0 Then GoTo br
   
6.         On Error Resume Next
   
7.         .Range(.Range("a65536").End(xlUp), .Range("ag1").End(xlDown)).SpecialCells(2, 1).ClearContents
   
8.         On Error GoTo 0
   
9.         Set c = .Columns("aj").Find(.Range("a2"), lookat:=xlWhole, SearchDirection:=1)
   
10.         Set c1 = .Columns("aj").Find(.Range("a2"), lookat:=xlWhole, SearchDirection:=2)
    
11.         If c Is Nothing Then
    
12. br:
    
13.             MsgBox "A2单元格数据输入错误!"
    
14.             Exit Sub
    
15.         End If
    
16.         arr = .Range(.Range("ag1"), .Range("a65536").End(xlUp))
    
17.         brr = .Range(c, .Cells(c1.Row, 69))
    
18.         k = .Range("bq1")
    
19.         na = Application.CountA(.Range(.Range("a1"), .Range("ag1")))
    
20.     End With
    
21.     Set c = Nothing
    
22.     Set c1 = Nothing
    
23.     For i = 1 To UBound(brr)
    
24.         For j = 3 To na + 1
    
25.             d(brr(i, 2) & arr(1, j - 1)) = brr(i, j)
    
26.         Next
    
27.         d(brr(i, 2) & k) = brr(i, 34)
    
28.     Next
    
29.     Erase brr
    
30.     For i = 10 To UBound(arr)
    
31.         For j = 2 To na
    
32.             s = arr(i, 1) & arr(1, j)
    
33.             If d.exists(s) Then
    
34.             If InStr(arr(1, j), "反") = 0 Then
    
35.                 arr(i, j) = IIf(d(s) > arr(2, j), 1, 0)
    
36.             Else
    
37.                 arr(i, j) = IIf(d(s) < arr(2, j), 1, 0)
    
38.             End If
    
39.             End If
    
40.         Next
    
41.         arr(i, 33) = d(arr(i, 1) & k)
    
42.     Next
    
43.     Set d = Nothing
    
44.     Sheets("sheet1").Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
45. End Sub
    
46. 
    

复制代码

ak47ok

liu-aguang 发表于 2014-9-17 19:32
应该与迅雷无关,可能是A2单元格内的数据没有找到.下列的代码增加了检测语句,如果数据没有找到或空,代码会有 ...

感动，谢谢老师！
只是多次在启动迅雷时就出现此情况，让VBA从本段代码的起始处重新运行、则在迅雷运行时也没有再提示出错。所以以为与迅雷有关。
老师贵姓？刘老师？

liu-aguang

ak47ok 发表于 2014-9-17 20:12
感动，谢谢老师！
只是多次在启动迅雷时就出现此情况，让VBA从本段代码的起始处重新运行、则在迅雷运行 ...

不用客气.其实你的题目并不复杂,道理上你应该可以自己处理的.

ak47ok

liu-aguang 发表于 2014-9-17 20:23
不用客气.其实你的题目并不复杂,道理上你应该可以自己处理的.

惭愧！
对VBA数组真是门外汉，昨天起在看佛山版主的入门教程。希望能学会。


我的签名“我的高级级别是问问题多而得到的，因为我文化不高，所以敬请高手照顾一下、谢谢！”
迟点是铁杆了，都不好意思提问了！

再次感谢老师！！！

ak47ok

liu-aguang 发表于 2014-9-17 19:32
应该与迅雷无关,可能是A2单元格内的数据没有找到.下列的代码增加了检测语句,如果数据没有找到或空,代码会有 ...

通过近期夜以继日的运算，想更进一步提高效率，在最后加插了2列数据，麻烦老师看看如何修改代码，谢谢！

liu-aguang

ak47ok 发表于 2014-10-11 11:03
通过近期夜以继日的运算，想更进一步提高效率，在最后加插了2列数据，麻烦老师看看如何修改代码，谢谢！

1. Sub test()
   
2.     Dim arr, d, i%, j%, brr, s$, k1$, k2$, k3$, c As Range, c1 As Range
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     With Sheets("sheet1")
   
5.         If Len(.Cells(2, 1)) = 0 Then GoTo br
   
6.         On Error Resume Next
   
7.         .Range(.Range("a65536").End(xlUp), .Range("ai1").End(xlDown)).SpecialCells(2, 1).ClearContents
   
8.         On Error GoTo 0
   
9.         Set c = .Columns("al").Find(.Range("a2"), lookat:=xlWhole, SearchDirection:=1)
   
10.         Set c1 = .Columns("al").Find(.Range("a2"), lookat:=xlWhole, SearchDirection:=2)
    
11.         If c Is Nothing Then
    
12. br:
    
13.             MsgBox "A2单元格数据输入错误!"
    
14.             Exit Sub
    
15.         End If
    
16.         arr = .Range(.Range("ai1"), .Range("a65536").End(xlUp))
    
17.         brr = .Range(c, .Cells(c1.Row, 73))
    
18.         k1 = .Range("bs1"): k2 = .Range("bt1"): k3 = .Range("bu1")
    
19.         na = Application.CountA(.Range(.Range("a1"), .Range("ag1")))
    
20.     End With
    
21.     Set c = Nothing
    
22.     Set c1 = Nothing
    
23.     For i = 1 To UBound(brr)
    
24.         For j = 3 To na + 1
    
25.             d(brr(i, 2) & arr(1, j - 1)) = brr(i, j)
    
26.         Next
    
27.         d(brr(i, 2) & k1) = brr(i, 34)
    
28.         d(brr(i, 2) & k2) = brr(i, 35)
    
29.         d(brr(i, 2) & k3) = brr(i, 36)
    
30.     Next
    
31.     Erase brr
    
32.     For i = 10 To UBound(arr)
    
33.         For j = 2 To na
    
34.             s = arr(i, 1) & arr(1, j)
    
35.             If d.exists(s) Then
    
36.             If InStr(arr(1, j), "反") = 0 Then
    
37.                 arr(i, j) = IIf(d(s) > arr(2, j), 1, 0)
    
38.             Else
    
39.                 arr(i, j) = IIf(d(s) < arr(2, j), 1, 0)
    
40.             End If
    
41.             End If
    
42.         Next
    
43.         arr(i, 33) = d(arr(i, 1) & k1)
    
44.         arr(i, 34) = d(arr(i, 1) & k2)
    
45.         arr(i, 35) = d(arr(i, 1) & k3)
    
46.     Next
    
47.     Set d = Nothing
    
48.     Sheets("sheet1").Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
49. End Sub
    

复制代码

lwx228

学习中，谢谢！

lwx228

liu-aguang 发表于 2014-10-11 12:10

借此题目请教老师：
要求更简单，但数据运算量更大，麻烦老师帮忙，谢谢！

liu-aguang

lwx228 发表于 2014-10-30 10:27
借此题目请教老师：
要求更简单，但数据运算量更大，麻烦老师帮忙，谢谢！

看似简单,但不完全明白意图.最好模拟一二个结果例子,才容易看懂.