[已解决]【重复数据累计统计】续1

mjola1

望帝春心 发表于 2016-12-5 21:44
resize那儿BD改成EF就行了

改不成功，明天教我一下。

望帝春心

mjola1 发表于 2016-12-5 22:24
改不成功，明天教我一下。

1. Sub tt()
   
2. Application.ScreenUpdating = False
   
3. Application.Interactive = False
   
4. Dim i&, dic As Object, arr1, brr()
   
5.     Set dic = CreateObject("scripting.dictionary")
   
6.     With Sheet1
   
7.         arr1 = .Cells(1, "a").Resize(.Cells(Rows.Count, "a").End(3).Row - 1, 2).Value
   
8.         Debug.Print UBound(arr1)
   
9.         For i = 1 To UBound(arr1)
   
10.             dic(arr1(i, 1)) = dic(arr1(i, 1)) + 1
    
11.         Next
    
12.         ReDim brr(1 To UBound(arr1))
    
13.         For i = 1 To UBound(arr1)
    
14.             brr(i) = dic(arr1(i, 1))
    
15.         Next
    
16.         .Cells(1, "e").Resize(UBound(arr1), 1) = brr
    
17.     End With
    
18. Dim m&, d As Object, arr2, brr1()
    
19.     Set d = CreateObject("scripting.dictionary")
    
20.     With Sheet1
    
21.         arr2 = .Cells(1, "c").Resize(.Cells(Rows.Count, "c").End(3).Row - 1, 2).Value
    
22.         For m = 1 To UBound(arr2)
    
23.             d(arr2(m, 1)) = d(arr2(m, 1)) + 1
    
24.         Next
    
25.         ReDim brr1(1 To UBound(arr2))
    
26.         For m = 1 To UBound(arr2)
    
27.             brr1(m) = d(arr2(m, 1))
    
28.         Next
    
29.         .Cells(1, "f").Resize(UBound(arr2), 1) = brr1
    
30.     End With
    
31. 'Dim x&
    
32.        'For x = 1 To 65600
    
33.        'Cells(x, "e") = Cells(x, "e") - 1
    
34.        'Cells(x, "b") = Cells(x, "b") + Cells(x, "e")
    
35.        'Cells(x, "f") = Cells(x, "f") - 1
    
36.        'Cells(x, "d") = Cells(x, "d") + Cells(x, "f")
    
37.    'Next
    
38.   Application.ScreenUpdating = True
    
39.   Application.Interactive = True
    
40.   End Sub

复制代码

望帝春心

mjola1 发表于 2016-12-5 22:24
改不成功，明天教我一下。

结果放到了EF列

mjola1

望帝春心 发表于 2016-12-7 08:00
结果放到了EF列

但新问题又出现了：运行后不统计重复次数了，不管插入多少条相同数据，计数皆为1.

望帝春心

mjola1 发表于 2016-12-7 10:03
但新问题又出现了：运行后不统计重复次数了，不管插入多少条相同数据，计数皆为1.

不好意思犯了低级错误

1. Sub tt()
   
2. Application.ScreenUpdating = False
   
3. Application.Interactive = False
   
4. Dim i&, dic As Object, arr1, brr()
   
5.     Set dic = CreateObject("scripting.dictionary")
   
6.     With Sheet1
   
7.         arr1 = .Cells(1, "a").Resize(.Cells(Rows.Count, "a").End(3).Row, 1).Value
   
8.         Debug.Print UBound(arr1)
   
9.         For i = 1 To UBound(arr1)
   
10.             dic(arr1(i, 1)) = dic(arr1(i, 1)) + 1
    
11.         Next
    
12.         ReDim brr(1 To UBound(arr1), 1 To 1)
    
13.         For i = 1 To UBound(arr1)
    
14.             brr(i, 1) = dic(arr1(i, 1))
    
15.         Next
    
16.         .Cells(1, "e").Resize(UBound(arr1), 1) = brr
    
17.     End With
    
18. Dim m&, d As Object, arr2, brr1()
    
19.     Set d = CreateObject("scripting.dictionary")
    
20.     With Sheet1
    
21.         arr2 = .Cells(1, "c").Resize(.Cells(Rows.Count, "c").End(3).Row, 1).Value
    
22.         For m = 1 To UBound(arr2)
    
23.             d(arr2(m, 1)) = d(arr2(m, 1)) + 1
    
24.         Next
    
25.         ReDim brr1(1 To UBound(arr2), 1 To 1)
    
26.         For m = 1 To UBound(arr2)
    
27.             brr1(m, 1) = d(arr2(m, 1))
    
28.         Next
    
29.         .Cells(1, "f").Resize(UBound(arr2), 1) = brr1
    
30.     End With
    
31. 'Dim x&
    
32.        'For x = 1 To 65600
    
33.        'Cells(x, "e") = Cells(x, "e") - 1
    
34.        'Cells(x, "b") = Cells(x, "b") + Cells(x, "e")
    
35.        'Cells(x, "f") = Cells(x, "f") - 1
    
36.        'Cells(x, "d") = Cells(x, "d") + Cells(x, "f")
    
37.    'Next
    
38.   Application.ScreenUpdating = True
    
39.   Application.Interactive = True
    
40.   End Sub

复制代码

基于前面附件的代码

望帝春心

1. 参考附件

复制代码

上清宫主

就你原有代码，略处理一下，省事省力
Sub tt()
Application.ScreenUpdating = False
Application.Interactive = False
Dim i&, dic As Object, arr1
    Set dic = CreateObject("scripting.dictionary")
    With Sheet1
        arr1 = .Cells(1, "a").Resize(.Cells(Rows.Count, "a").End(3).Row - 1, 2).Value
        For i = 1 To UBound(arr1)
            dic(arr1(i, 1)) = dic(arr1(i, 1)) + 1
        Next
        For i = 1 To UBound(arr1)
            'arr1(i, 2) = dic(arr1(i, 1))
            '换为下一句:
            arr1(i, 1) = dic(arr1(i, 1))
        Next
        '.Cells(1, "e").Resize(UBound(arr1), 1) = Application.Index(arr1, , 2)
        '换为下一句:
        .Cells(1, "e").Resize(UBound(arr1), 1) = arr1
    End With
Dim m&, d As Object, arr2
    Set d = CreateObject("scripting.dictionary")
    With Sheet1
        arr2 = .Cells(1, "c").Resize(.Cells(Rows.Count, "c").End(3).Row - 1, 2).Value
        For m = 1 To UBound(arr2)
            d(arr2(m, 1)) = d(arr2(m, 1)) + 1
        Next
        For m = 1 To UBound(arr2)
            'arr2(m, 2) = d(arr2(m, 1))同理
            arr2(m, 1) = d(arr2(m, 1))
        Next
        '.Cells(1, "f").Resize(UBound(arr2), 1) = Application.Index(arr2, , 2)同理
        .Cells(1, "f").Resize(UBound(arr2), 1) = arr2
    End With
Dim x&
'下面的循环可以不要，处理办法见里面的文字
      ' For x = 1 To 65600
      ' Cells(x, "e") = Cells(x, "e") - 1 此处就是将E列统一减1，可以直接在上面的arr1(i, 1) = dic(arr1(i, 1))改成
      'arr1(i, 1) = dic(arr1(i, 1))-1,也可在此处复制一个1再选择性粘贴---数值---减来实现
      ' Cells(x, "b") = Cells(x, "b") + Cells(x, "e") 你B列为空，实际也就是把E列复制过去。如果B列有值，还可以如上一行的选择性粘贴
      ' Cells(x, "f") = Cells(x, "f") - 1 此处及下一行同上
      ' Cells(x, "d") = Cells(x, "d") + Cells(x, "f")
   'Next
  Application.ScreenUpdating = True
  Application.Interactive = True
  End Sub

mjola1

望帝春心 发表于 2016-12-7 10:53

Sub tt()
Application.ScreenUpdating = False
Application.Interactive = False
Dim i&, dic As Object, arr1, brr()
    Set dic = CreateObject("scripting.dictionary")
    With Sheet1
        arr1 = .Cells(1, "a").Resize(.Cells(Rows.Count, "a").End(3).Row, 1).Value
        Debug.Print UBound(arr1)
        For i = 1 To UBound(arr1)
            dic(arr1(i, 1)) = dic(arr1(i, 1)) + 1
        Next
        ReDim brr(1 To UBound(arr1), 1 To 1)
        For i = 1 To UBound(arr1)
        brr(i, 1) = dic(arr1(i, 1)) - 1
        Next
        .Cells(1, "e").Resize(UBound(arr1), 1) = brr
    End With
Dim m&, di As Object, arr2, brr1()
    Set di = CreateObject("scripting.dictionary")
    With Sheet1
        arr2 = .Cells(1, "c").Resize(.Cells(Rows.Count, "c").End(3).Row, 1).Value
        For m = 1 To UBound(arr2)
            di(arr2(m, 1)) = di(arr2(m, 1)) + 1
        Next
        ReDim brr1(1 To UBound(arr2), 1 To 1)
        For m = 1 To UBound(arr2)
            brr1(m, 1) = di(arr2(m, 1)) - 1
        Next
        .Cells(1, "f").Resize(UBound(arr2), 1) = brr1
    End With
Dim e, b, f, d
     e = [e1:e518400]
     b = [b1:b518400]
     [b1:b518400] = Evaluate("b1:b518400+e1:e518400"): Range("e1:e518400").Clear
     f = [f1:f518400]
     d = [d1:d518400]
     [d1:d518400] = Evaluate("d1:d518400+f1:f518400"): Range("f1:f518400").Clear
  Application.ScreenUpdating = True
  Application.Interactive = True
  End Sub
测试1066800条数据，耗时35秒，比较满意。可惜不能将e = [e1:e518400]换成e = [brr(1, 1)：brr(518400, 1)]，不向单元格写入 .Cells(1, "e").Resize(UBound(arr1), 1) = brr就好了，这句和.Cells(1, "f").Resize(UBound(arr2), 1) = brr1这句起码耗时10秒。能不能再提速？

望帝春心

mjola1 发表于 2016-12-7 14:47
Sub tt()
Application.ScreenUpdating = False
Application.Interactive = False

原来直接写到BD列的结果你要写到EF列，完了你又反写回来，再把辅助区域删了，不知道你是几个意思

望帝春心

“可惜不能将e = [e1:e518400]换成e = [brr(1, 1)：brr(518400, 1)]，不向单元格写入 .Cells(1, "e").Resize(UBound(arr1), 1) = brr就好了，这句和.Cells(1, "f").Resize(UBound(arr2), 1) = brr1这句起码耗时10秒”不理解什么意思，结果不用数组写入单元格，那怎么写？