[已解决]求修改

爱很简单

求高手修改

最佳答案

月排行榜 / 总排行榜

芐雨

2015-1-13 15:25

1. Sub 按钮1_Click()
   
2.     Dim arr, brr, i&, j&, dic As Object
   
3.     Set dic = VBA.CreateObject("scripting.dictionary")
   
4.     arr = Range("C4:C" & Cells(Rows.Count, "C").End(3).Row)
   
5.     ar = Range("I4:I" & Cells(Rows.Count, "C").End(3).Row)
   
6.     ReDim brr(1 To UBound(arr), 1 To 2)
   
7.     For i = 1 To UBound(arr)
   
8.         If dic.exists(arr(i, 1)) Then
   
9.             If ar(i, 1) < dic(arr(i, 1)) Then dic(arr(i, 1)) = ar(i, 1)
   
10.         Else
    
11.             dic(arr(i, 1)) = ar(i, 1)
    
12.         End If
    
13.     Next
    
14. 
    
15.     For i = 1 To UBound(arr)
    
16.         If ar(i, 1) = dic(arr(i, 1)) Then
    
17.             brr(i, 1) = 1
    
18.             dic(arr(i, 1)) = -1
    
19.         Else
    
20.             brr(i, 1) = "重复"
    
21.             brr(i, 2) = 1
    
22.         End If
    
23.     Next
    
24. 
    
25.     Range("Q4:R" & Rows.Count).Clear
    
26.     Range("Q4").Resize(UBound(arr), 2) = brr
    
27. End Sub
    

复制代码

跳转到最佳答案楼层

芐雨

1. Sub 按钮1_Click()
   
2.     Dim arr, brr, i&, j&, dic As Object
   
3.     Set dic = VBA.CreateObject("scripting.dictionary")
   
4.     arr = Range("C4:C" & Cells(Rows.Count, "C").End(3).Row)
   
5.     ar = Range("I4:I" & Cells(Rows.Count, "C").End(3).Row)
   
6.     ReDim brr(1 To UBound(arr), 1 To 2)
   
7.     For i = 1 To UBound(arr)
   
8.         If dic.exists(arr(i, 1)) Then
   
9.             If ar(i, 1) < dic(arr(i, 1)) Then dic(arr(i, 1)) = ar(i, 1)
   
10.         Else
    
11.             dic(arr(i, 1)) = ar(i, 1)
    
12.         End If
    
13.     Next
    
14. 
    
15.     For i = 1 To UBound(arr)
    
16.         If ar(i, 1) = dic(arr(i, 1)) Then
    
17.             brr(i, 1) = 1
    
18.         Else
    
19.             brr(i, 1) = "重复"
    
20.             brr(i, 2) = 1
    
21.         End If
    
22.     Next
    
23. 
    
24.     Range("Q4:R" & Rows.Count).Clear
    
25.     Range("Q4").Resize(UBound(arr), 2) = brr
    
26. End Sub

复制代码

芐雨

。。。。。。。。。
数组方面1.zip (10.95 KB, 下载次数: 7)

2015-1-13 15:02 上传

点击文件名下载附件

爱很简单

芐雨 发表于 2015-1-13 15:02
。。。。。。。。。

您好，其他功能都实现了，谢谢您。还有一个问题我没有说的清楚，就是日期相等，只能算一次。随便算那一个都行，这个是修改哪里啊，谢谢您了

爱很简单

芐雨 发表于 2015-1-13 15:02
。。。。。。。。。

对不起·· 我忽略日期相等的了。表中日期相等的较多，日期相等的只能是算出现一次！！！！

芐雨

1. Sub 按钮1_Click()
   
2.     Dim arr, brr, i&, j&, dic As Object
   
3.     Set dic = VBA.CreateObject("scripting.dictionary")
   
4.     arr = Range("C4:C" & Cells(Rows.Count, "C").End(3).Row)
   
5.     ar = Range("I4:I" & Cells(Rows.Count, "C").End(3).Row)
   
6.     ReDim brr(1 To UBound(arr), 1 To 2)
   
7.     For i = 1 To UBound(arr)
   
8.         If dic.exists(arr(i, 1)) Then
   
9.             If ar(i, 1) < dic(arr(i, 1)) Then dic(arr(i, 1)) = ar(i, 1)
   
10.         Else
    
11.             dic(arr(i, 1)) = ar(i, 1)
    
12.         End If
    
13.     Next
    
14. 
    
15.     For i = 1 To UBound(arr)
    
16.         If ar(i, 1) = dic(arr(i, 1)) Then
    
17.             brr(i, 1) = 1
    
18.             dic(arr(i, 1)) = -1
    
19.         Else
    
20.             brr(i, 1) = "重复"
    
21.             brr(i, 2) = 1
    
22.         End If
    
23.     Next
    
24. 
    
25.     Range("Q4:R" & Rows.Count).Clear
    
26.     Range("Q4").Resize(UBound(arr), 2) = brr
    
27. End Sub
    

复制代码