[已解决]怎么没有能回答的，高手在哪里，请问，任选区域挑出重复的数，用vba怎么编程

xchyb

在工作表1中用鼠标任选一区域，从中挑选出重复的数（有可能重复多次），在工作表2中显示出来（a1为顶点向右或者向下排列显示出来），能否给出vba编程代码，谢谢。

最佳答案

月排行榜 / 总排行榜

dsmch

2015-3-15 23:22

1. Sub Macro1()
   
2. Dim rng As Range, arr, d, i&, s&, j%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Sheet1.Activate
   
5. Sheet2.[a:a] = ""
   
6. Set rng = Application.InputBox("请用鼠标选中数据区域", Type:=8)
   
7. If rng.Count < 2 Then Exit Sub
   
8. arr = rng
   
9. For i = 1 To UBound(arr)
   
10.     For j = 1 To UBound(arr, 2)
    
11.         d(arr(i, j)) = d(arr(i, j)) + 1
    
12.         If d(arr(i, j)) = 2 Then s = s + 1: Sheet2.Cells(s, 1) = arr(i, j)
    
13.     Next
    
14. Next
    
15. Sheet2.Activate
    
16. End Sub

复制代码

跳转到最佳答案楼层

qh8600

上传个附件吧

xchyb

比如，这个文件里，工作表1的a1到n35区域，挑出重复的数。在工作表2从a1的位置开始，向下，把工作表1的重复的数，显示出来。谢谢高手，解答，期待中。

xchyb

qh8600 发表于 2015-3-15 10:36
上传个附件吧

附件传上了，老师能帮我看看吗

xchyb

一天了，还是没有人能回答上来

雪舞子

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     Dim d As Object, arr, a, ar, br, brr(), i%, n%
   
3.     arr = Target
   
4.     If IsArray(arr) Then
   
5.         Set d = CreateObject("scripting.dictionary")
   
6.         For Each a In arr
   
7.             d(a) = d(a) + 1
   
8.         Next
   
9.         ReDim brr(1 To d.Count, 1 To 1)
   
10.         ar = d.keys: br = d.items
    
11.         For i = 0 To d.Count - 1
    
12.             If br(i) > 1 Then
    
13.                 n = n + 1
    
14.                 brr(n, 1) = ar(i)
    
15.             End If
    
16.         Next
    
17.         Set d = Nothing
    
18.         With Sheets(2)
    
19.             .Activate
    
20.             .[a1].CurrentRegion = ""
    
21.             .[a1].Resize(UBound(brr)) = brr
    
22.         End With
    
23.     End If
    
24. End Sub

复制代码

找出重复的数输出到工作表2.rar (17.6 KB, 下载次数: 12)

2015-3-15 22:27 上传

点击文件名下载附件

dsmch

1. Sub Macro1()
   
2. Dim rng As Range, arr, d, i&, s&, j%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Sheet1.Activate
   
5. Sheet2.[a:a] = ""
   
6. Set rng = Application.InputBox("请用鼠标选中数据区域", Type:=8)
   
7. If rng.Count < 2 Then Exit Sub
   
8. arr = rng
   
9. For i = 1 To UBound(arr)
   
10.     For j = 1 To UBound(arr, 2)
    
11.         d(arr(i, j)) = d(arr(i, j)) + 1
    
12.         If d(arr(i, j)) = 2 Then s = s + 1: Sheet2.Cells(s, 1) = arr(i, j)
    
13.     Next
    
14. Next
    
15. Sheet2.Activate
    
16. End Sub

复制代码

xchyb

雪舞子 发表于 2015-3-15 22:28

谢谢，太厉害了

xchyb

dsmch 发表于 2015-3-15 23:22

谢谢，太厉害了，还加了按钮，很方便

xchyb

雪舞子  和  dsmch  两位高手都很给力，两个程序，都好用，我就是看不懂，惭愧，非常感谢两位的回答，在这里我在加点难度，当时我还没有想到，就是，在给出答案的数的旁边，就是第二列，把第一列数字频率能否一并给出。