[已解决]求助vba

yuio123

BOOK1.rar (80.49 KB, 下载次数: 25)

2013-12-19 16:22 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

xdragon

2013-12-19 16:33

1. Sub distinct()
   
2.   Dim arr, brr, crr(), d1 As Object, d2 As Object, i As Integer, j, cnt As Long, c As Collection
   
3.   Set d1 = CreateObject("scripting.dictionary")
   
4. 
   
5.   For i = 1 To 4
   
6.     arr = Sheets(CStr(i)).Range("K3:K1000")
   
7.     For Each j In arr
   
8.       d1(i & "|" & j) = d1(i & "|" & j) + 1
   
9.     Next
   
10.   Next
    
11.   arr = d1.keys
    
12.   brr = d1.items
    
13.   d1.RemoveAll
    
14. 
    
15.   Set d2 = CreateObject("scripting.dictionary")
    
16.   For i = 0 To UBound(arr)
    
17.      j = Split(arr(i), "|")(1)
    
18.      d1(j & "|" & brr(i)) = d1(j & "|" & brr(i)) + 1
    
19.      If d1(j & "|" & brr(i)) > 2 Then d2(j) = ""
    
20.   Next
    
21. 
    
22.   Range("A1:A" & d2.Count) = Application.Transpose(d2.keys)
    
23. End Sub

复制代码

这题之前有人问过的了。。。

跳转到最佳答案楼层

xdragon

1. Sub distinct()
   
2.   Dim arr, brr, crr(), d1 As Object, d2 As Object, i As Integer, j, cnt As Long, c As Collection
   
3.   Set d1 = CreateObject("scripting.dictionary")
   
4. 
   
5.   For i = 1 To 4
   
6.     arr = Sheets(CStr(i)).Range("K3:K1000")
   
7.     For Each j In arr
   
8.       d1(i & "|" & j) = d1(i & "|" & j) + 1
   
9.     Next
   
10.   Next
    
11.   arr = d1.keys
    
12.   brr = d1.items
    
13.   d1.RemoveAll
    
14. 
    
15.   Set d2 = CreateObject("scripting.dictionary")
    
16.   For i = 0 To UBound(arr)
    
17.      j = Split(arr(i), "|")(1)
    
18.      d1(j & "|" & brr(i)) = d1(j & "|" & brr(i)) + 1
    
19.      If d1(j & "|" & brr(i)) > 2 Then d2(j) = ""
    
20.   Next
    
21. 
    
22.   Range("A1:A" & d2.Count) = Application.Transpose(d2.keys)
    
23. End Sub

复制代码

这题之前有人问过的了。。。

上清宫主

Sub test()
Dim ar1(), ar2%(0 To 999)
For i1% = 1 To Sheets.Count
    With Sheets(i1)
       r% = .[k65536].End(3).Row
       ar1 = .Range("k3:k" & r).Value
       For Each tmp In ar1
           ar2(tmp * 1) = ar2(tmp * 1) + 1
       Next
       r = 0
        For i2% = 0 To 999
           If ar2(i2) > 2 Then
              r = r + 1
              ar1(r, 1) = Right("00" & i2, 3)
           End If
       Next
       Erase ar2
       If r > 0 Then Sheets(1).[a65536].End(3)(2, 1).Resize(r, 1) = ar1
    End With
Next
End Sub

上清宫主

不明白楼主的了，学委的代码是对的？

yuio123

上清宫主 发表于 2013-12-19 17:04
不明白楼主的了，学委的代码是对的？

不好意思他是错的

xdragon

1. Sub distinct()
   
2.   Dim arr, brr(), d As Object, i As Integer, j, cnt As Long
   
3. 
   
4.   For i = 1 To 4
   
5.     arr = Sheets(CStr(i)).Range("K3:K1000")
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     For Each j In arr
   
8.       d(j) = d(j) + 1
   
9.       If d(j) > 2 Then
   
10.         cnt = cnt + 1
    
11.         ReDim Preserve brr(1 To cnt)
    
12.         brr(cnt) = j
    
13.       End If
    
14.     Next
    
15.     Set d = Nothing
    
16.   Next
    
17.   Range("A1").Resize(cnt) = Application.Transpose(brr)
    
18. End Sub

复制代码

楼主啊，这个答的不对你也别评最佳啊，你可以参照上宫的，或者看我这里补充的。
没看清你的题意以为和之前那个是一样的了。。抱歉。。。

上清宫主

学委在6楼还是没补对

xdragon

上清宫主 发表于 2013-12-19 20:38
学委在6楼还是没补对

上宫你看下，我运行了你的结果看过，你的结果是有两个 000 ，可是根据楼主的意思，应该是每个工作表K列中重复项大于2的才统计吧？我查了几个表，并没有重复的000出现啊。。。我分别做了数据透视表看了下重复值，最多的就是2个，并没有超过2个的>_<