我要把一个工作表中的数据无重复添加到另一个工作表中

hqmtba

      像今天的数据有1万5千多行，运用14楼附表中的公式运行时间估计在两个半小时左右，又是一个难以等待的时间，现在闲等高手的代码，我一直相信应该能通过代码实现的，但过程可能有点繁琐，尽管自己也在努力的学习VBA，但远水解不了近渴！

Vicel

hqmtba 发表于 2015-1-27 15:38
像今天的数据有1万5千多行，运用14楼附表中的公式运行时间估计在两个半小时左右，又是一个难以等待的 ...

代码出来了，可跟楼主的结果不太一致，不知何因。请测试

1. Sub test()
   
2.     Dim ar, br, i, k, n, s, d As Object, dd As Object
   
3.     On Error Resume Next
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set dd = CreateObject("scripting.dictionary")
   
6.     With Sheets("Sheet1")
   
7.         ar = Range("A2:G" & .[A65536].End(xlUp).Row)
   
8.     End With
   
9.     For i = 1 To UBound(ar)
   
10.         If Not d.exists(ar(i, 1) & "," & ar(i, 3) & "," & ar(i, 6) & "," & ar(i, 7)) Then
    
11.             d(ar(i, 1) & "," & ar(i, 3) & "," & ar(i, 6) & "," & ar(i, 7)) = ""
    
12.             s = --Left(ar(i, 6), Len(ar(i, 6)) - 2)
    
13.             If Not dd.exists(ar(i, 2) & "," & ar(i, 3)) Then
    
14.                 If ar(i, 1) = "大额买单" Then
    
15.                     dd(ar(i, 2) & "," & ar(i, 3)) = ar(i, 2) & "," & ar(i, 3) & "," & s & ",0,0,0," & s & ",0"
    
16.                 Else
    
17.                     dd(ar(i, 2) & "," & ar(i, 3)) = ar(i, 2) & "," & ar(i, 3) & ",0," & s & ",0,0,0," & s
    
18.                 End If
    
19.             Else
    
20.                 br = Split(dd(ar(i, 2) & "," & ar(i, 3)), ",")
    
21.                 If ar(i, 1) = "大额买单" Then
    
22.                     br(2) = s + br(2): br(6) = Application.Max(s, br(6))
    
23.                 Else
    
24.                     br(3) = s + br(3): br(7) = Application.Max(s, br(7))
    
25.                 End If
    
26.                 dd(ar(i, 2) & "," & ar(i, 3)) = Join(br, ",")
    
27.             End If
    
28.         End If
    
29.     Next i
    
30.     ReDim ar(1 To dd.Count, 1 To 8)
    
31.     For Each k In dd.keys
    
32.         br = Split(dd(k), ",")
    
33.         br(4) = br(2) - br(3)
    
34.         If Val(br(3)) = 0 Then
    
35.             br(5) = "无大卖单"
    
36.         Else
    
37.             br(5) = Round(br(2) / br(3), 2)
    
38.         End If
    
39.         n = n + 1
    
40.         For i = 1 To UBound(br) + 1
    
41.             ar(n, i) = br(i - 1)
    
42.         Next i
    
43.     Next
    
44.     With Sheets("结果")
    
45.         .UsedRange.Offset(1, 0).ClearContents
    
46.         .[A2].Resize(n, 8) = ar
    
47.     End With
    
48.     Set d = Nothing
    
49.     Set dd = Nothing
    
50. End Sub
    

复制代码

附表.zip (125.12 KB, 下载次数: 61)

2015-1-27 20:58 上传

点击文件名下载附件

hqmtba

Vicel 发表于 2015-1-27 20:58
代码出来了，可跟楼主的结果不太一致，不知何因。请测试

    哇哦，太爽了，我刚刚用今天的新数据测试了下，和我的公式运行结果完全一致，费时不到十秒，而我今天用公式运行差不多费了两个半小时，可解决我的大问题了！非常非常感谢您的代码，我准备再把生成源数据的代码整合进来，也挑战下运用代码解决问题，说不定还要仰仗您的！我弄好的话也分享给您及关注的各位。

hqmtba

Vicel 发表于 2015-1-27 20:58
代码出来了，可跟楼主的结果不太一致，不知何因。请测试

对了，关于您说的结果不一致问题，18楼也提出来了，我后来再运用公式算了，确实有问题，应该是我只注重讲清楚要求，把另一天的结果贴到了这里而导致的，并不是代码问题！

hqmtba

Vicel 发表于 2015-1-27 20:58
代码出来了，可跟楼主的结果不太一致，不知何因。请测试

有个问题来了，我把代码剪贴到模块中，运行后结果不对了，而且每运行一次结果又和上次不一致，看了半天想不清所以然，还请帮忙

Vicel

hqmtba 发表于 2015-1-27 21:43
有个问题来了，我把代码剪贴到模块中，运行后结果不对了，而且每运行一次结果又和上次不一致，看了半天想 ...

留意22楼代码的第6行、44行工作表名是否一致

hqmtba

hqmtba 发表于 2015-1-27 21:43
有个问题来了，我把代码剪贴到模块中，运行后结果不对了，而且每运行一次结果又和上次不一致，看了半天想 ...

解决了，就是把22楼的第7行代码改成“ar = Sheets("Sheet1").Range("A2:G" & .[A65536].End(xlUp).Row)”

hqmtba

Vicel 发表于 2015-1-27 20:58
代码出来了，可跟楼主的结果不太一致，不知何因。请测试

      细看发现了个细节问题，就是sheet1中的A列“异动类型”有四种情况：大额买单、大额卖单、单笔异涨、单笔异跌，后两者的单笔成交额是不能统计到“大额买和”或“大额卖和”中去的，您的结果在某只股票出现“单笔异涨”或“单笔异跌”时，“结果”中的“大额卖和”应该是偏大的。另外，Sheet1中的H列-L列数据的生成还是想麻烦您帮我通过代码生成，免得因为每次的数据行数不固定，又要手工弄一下。有劳了！

hqmtba

Vicel 发表于 2015-1-27 22:12
留意22楼代码的第6行、44行工作表名是否一致

这个我注意到了，不应该一致的，是吧！

Vicel

hqmtba 发表于 2015-1-27 23:24
细看发现了个细节问题，就是sheet1中的A列“异动类型”有四种情况：大额买单、大额卖单、单笔异涨、 ...

1. Sub test()
   
2.     Dim ar, br, cr(), i, k, n, s, d As Object, dd As Object
   
3.     On Error Resume Next
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set dd = CreateObject("scripting.dictionary")
   
6.     With Sheets("Sheet1")
   
7.         ar = .Range("A2:G" & .[A65536].End(xlUp).Row)
   
8.     End With
   
9.     ReDim cr(1 To UBound(ar), 1 To 5)
   
10.     For i = 1 To UBound(ar)
    
11.         cr(i, 1) = --Left(ar(i, 6), Len(ar(i, 6)) - 2)
    
12.         If ar(i, 1) = "大额买单" And ar(i, 5) < -3 / 100 And cr(i, 1) > 500 Then
    
13.             cr(i, 2) = "√"
    
14.         Else
    
15.             cr(i, 2) = ""
    
16.         End If
    
17.         If ar(i, 1) = "大额买单" And ar(i, 5) < -5 / 100 And cr(i, 1) > 500 Then
    
18.             cr(i, 3) = "√"
    
19.         Else
    
20.             cr(i, 3) = ""
    
21.         End If
    
22.         If ar(i, 1) = "大额买单" And cr(i, 1) > 1000 Then
    
23.             cr(i, 4) = "√"
    
24.         Else
    
25.             cr(i, 4) = ""
    
26.         End If
    
27.         If Not d.exists(ar(i, 1) & "," & ar(i, 3) & "," & ar(i, 6) & "," & ar(i, 7)) Then
    
28.             cr(i, 5) = ""
    
29.             d(ar(i, 1) & "," & ar(i, 3) & "," & ar(i, 6) & "," & ar(i, 7)) = ""
    
30.             s = cr(i, 1)
    
31.             If Not dd.exists(ar(i, 2) & "," & ar(i, 3)) Then
    
32.                 If ar(i, 1) = "大额买单" Then
    
33.                     dd(ar(i, 2) & "," & ar(i, 3)) = ar(i, 2) & "," & ar(i, 3) & "," & s & ",0,0,0," & s & ",0"
    
34.                 ElseIf ar(i, 1) = "大额卖单" Then
    
35.                     dd(ar(i, 2) & "," & ar(i, 3)) = ar(i, 2) & "," & ar(i, 3) & ",0," & s & ",0,0,0," & s
    
36.                 End If
    
37.             Else
    
38.                 br = Split(dd(ar(i, 2) & "," & ar(i, 3)), ",")
    
39.                 If ar(i, 1) = "大额买单" Then
    
40.                     br(2) = s + br(2): br(6) = Application.Max(s, br(6))
    
41.                 ElseIf ar(i, 1) = "大额卖单" Then
    
42.                     br(3) = s + br(3): br(7) = Application.Max(s, br(7))
    
43.                 End If
    
44.                 dd(ar(i, 2) & "," & ar(i, 3)) = Join(br, ",")
    
45.             End If
    
46.         Else
    
47.             cr(i, 5) = "a"
    
48.         End If
    
49.     Next i
    
50.     ReDim ar(1 To dd.Count, 1 To 8)
    
51.     For Each k In dd.keys
    
52.         br = Split(dd(k), ",")
    
53.         br(4) = br(2) - br(3)
    
54.         If Val(br(3)) = 0 Then
    
55.             br(5) = "无大卖单"
    
56.         Else
    
57.             br(5) = Round(br(2) / br(3), 2)
    
58.         End If
    
59.         n = n + 1
    
60.         For i = 1 To UBound(br) + 1
    
61.             ar(n, i) = br(i - 1)
    
62.         Next i
    
63.     Next
    
64.     Sheets("Sheet1").[H2].Resize(UBound(cr), 5) = cr
    
65.     With Sheets("结果")
    
66.         .UsedRange.Offset(1, 0).ClearContents
    
67.         .[A2].Resize(n, 8) = ar
    
68.     End With
    
69.     Set d = Nothing
    
70.     Set dd = Nothing
    
71. End Sub
    

复制代码