[已解决]帮忙完善统计重复项的功能

grf1973

我把代码改了一下，请测试。

1. Sub tt()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     r = [b65536].End(3).Row
   
4.     [f3:f65536] = ""
   
5.     arr = Range("a1:f" & r)
   
6.     For i = 3 To UBound(arr)
   
7.         x = Trim(arr(i, 3))
   
8.         x = Replace(x, " ", "")  '项目名称去空格作为key
   
9.         d(x) = d(x) & "," & i   '相同项目名称所在的行数作为item
   
10.     Next
    
11.     dt = d.items
    
12.     For i = 1 To UBound(dt)
    
13.         xrr = Split(dt(i), ","): n = UBound(xrr)   'xrr为'相同项目名称所在的行数的数组
    
14.         If n > 1 Then  'n>1表示一个项目有2个以上行
    
15.             yrr = xrr
    
16.             For j = 1 To n - 1
    
17.                 If xrr(j + 1) - xrr(j) = 1 Then yrr(j) = 0: yrr(j + 1) = 0
    
18.             Next
    
19.             s = Join(yrr, ","): s = Replace(s, ",0", "")
    
20.             For j = 1 To n
    
21.                 k = xrr(j)
    
22.                 If Len(s) = 0 Then arr(k, 6) = "正常" Else arr(k, 6) = "重复：" & Mid(dt(i), 2)
    
23.             Next
    
24.         End If
    
25.     Next
    
26.     [f1].Resize(UBound(arr), 1) = Application.Index(arr, , 6)
    
27. End Sub
    

复制代码

grf1973

加了注释。

1. Sub tt()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     r = [b65536].End(3).Row
   
4.     [f3:f65536] = ""
   
5.     arr = Range("a1:f" & r)
   
6.     For i = 3 To UBound(arr)
   
7.         x = Trim(arr(i, 3))
   
8.         x = Replace(x, " ", "")  '项目名称去空格作为key
   
9.         d(x) = d(x) & "," & i   '相同项目名称所在的行数作为item
   
10.     Next
    
11.     dt = d.items
    
12.     For i = 1 To UBound(dt)
    
13.         xrr = Split(dt(i), ","): n = UBound(xrr)   'xrr为'相同项目名称所在的行数的数组
    
14.         If n > 1 Then  'n>1表示一个项目有2个以上行
    
15.             yrr = xrr   '令yrr和xrr数组相同，以作比较
    
16.             For j = 1 To n - 1
    
17.                 If xrr(j + 1) - xrr(j) = 1 Then yrr(j) = 0: yrr(j + 1) = 0   '如果行数相邻，yrr对应项设为0
    
18.             Next
    
19.             s = Join(yrr, ","): s = Replace(s, ",0", "")   'yrr字符串相连把，把0去掉，如果去掉后字符串为0，说明所有行数均相邻
    
20.             For j = 1 To n
    
21.                 k = xrr(j)
    
22.                 If Len(s) = 0 Then arr(k, 6) = "正常" Else arr(k, 6) = "重复：" & Mid(dt(i), 2)  '如果相邻，输出正常，否则输出重复行数
    
23.             Next
    
24.         End If
    
25.     Next
    
26.     [f1].Resize(UBound(arr), 1) = Application.Index(arr, , 6)
    
27. End Sub
    

复制代码

grf1973

请看附件。应该没问题了。

guanghui2099

grf1973 发表于 2014-5-12 09:26
请看附件。应该没问题了。

谢谢，问题已解决