[已解决]求助VBA条件有点改动

uuw5

Book1.rar (8.28 KB, 下载次数: 8)

2013-9-21 11:23 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2013-9-21 12:39

附件请测试

1. Private Sub CommandButton1_Click()
   
2. Dim arr, i&, j&, k&, d As Object, d1 As Object, c
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d1 = CreateObject("scripting.dictionary")
   
5. Columns(1).ClearContents
   
6. For k = 6 To 9
   
7.   arr = Range(Cells(2, k), Cells(46, k))
   
8.   For i = 1 To 45 Step 9
   
9.     For j = i To i + 8
   
10.       If arr(j, 1) <> "" Then d(arr(j, 1)) = d(arr(j, 1)) + 1
    
11.     Next j
    
12.     For Each c In d.keys
    
13.       If d(c) > 1 Then d1(c) = d1(c) + 1
    
14.     Next c
    
15.     d.RemoveAll
    
16.   Next i
    
17.   For Each c In d1.keys
    
18.     If d1(c) < 5 Then d1.Remove (c)
    
19.   Next c
    
20.   If d1.Count > 0 Then Cells([a65536].End(3).Row + 1, 1).Resize(d1.Count) = Application.Transpose(d1.keys)
    
21.   d1.RemoveAll
    
22. Next k
    
23. End Sub

复制代码

跳转到最佳答案楼层

danio112

Sub 找重复值()
Set d = CreateObject("scripting.dictionary")
Set t = CreateObject("scripting.dictionary")
Dim arr(1 To 5, 1 To 9)

For i = 1 To 5 '把F例的数据放入数组
For j = 1 To 9
arr(i, j) = Range("f" & (i - 1) * 9 + j + 1)
Next
Next

For i = 1 To 5
For j = 1 To 9
  If arr(i, j) <> "" Then
   If d.exists(arr(i, j)) = True Then
   t(arr(i, j)) = ""　如果重复，则放入一个新的字典
   Else
   d(arr(i, j)) = ""
   End If
  End If
Next
d.RemoveAll
Next
k = t.Count
Range("a2").Resize(k) = Application.Transpose(t.keys)　’取出字典里的数据
End Sub
   
与之前的改变是，字典t一直保留，最后输出。之前是每循环一次，输出字典数据，清空，再循环。

大灰狼1976

附件请测试

1. Private Sub CommandButton1_Click()
   
2. Dim arr, i&, j&, k&, d As Object, d1 As Object, c
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d1 = CreateObject("scripting.dictionary")
   
5. Columns(1).ClearContents
   
6. For k = 6 To 9
   
7.   arr = Range(Cells(2, k), Cells(46, k))
   
8.   For i = 1 To 45 Step 9
   
9.     For j = i To i + 8
   
10.       If arr(j, 1) <> "" Then d(arr(j, 1)) = d(arr(j, 1)) + 1
    
11.     Next j
    
12.     For Each c In d.keys
    
13.       If d(c) > 1 Then d1(c) = d1(c) + 1
    
14.     Next c
    
15.     d.RemoveAll
    
16.   Next i
    
17.   For Each c In d1.keys
    
18.     If d1(c) < 5 Then d1.Remove (c)
    
19.   Next c
    
20.   If d1.Count > 0 Then Cells([a65536].End(3).Row + 1, 1).Resize(d1.Count) = Application.Transpose(d1.keys)
    
21.   d1.RemoveAll
    
22. Next k
    
23. End Sub

复制代码