[已解决]求个vba

lkjhuy

取数.rar (71.03 KB, 下载次数: 12)

2013-12-22 14:47 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

yyyydddd8888

2013-12-22 17:33

lkjhuy 发表于 2013-12-22 17:26
打不开zip文件直上代码吧

传一个rar:
取数.rar (264.58 KB, 下载次数: 2)

2013-12-22 17:34 上传

点击文件名下载附件

1. Sub 提取()
   
2. Dim arr, brr(1 To 10000, 1 To 1), d As Object, i&, j&, k&
   
3. Dim d1 As Object, temp
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d1 = CreateObject("scripting.dictionary")
   
6. For i = 1 To 5
   
7.     arr = Sheets(i).Range("k3:k1000")
   
8.     For j = 1 To UBound(arr)
   
9.           d(arr(j, 1)) = ""
   
10.     Next j
    
11.           temp = d.keys
    
12.     For j = 1 To d.Count
    
13.         k = k + 1
    
14.         brr(k, 1) = temp(j - 1)
    
15.     Next j
    
16.           d.RemoveAll
    
17. Next i
    
18.    For i = 1 To k
    
19.        d1(brr(i, 1)) = d1(brr(i, 1)) + 1
    
20.    Next i
    
21.        temp = d1.keys
    
22.        Erase brr
    
23.        k = 0
    
24.    For i = 1 To d1.Count
    
25.        If d1(temp(i - 1)) > 2 Then
    
26.         k = k + 1
    
27.         brr(k, 1) = temp(i - 1)
    
28.        End If
    
29.    Next i
    
30.    Sheets(1).Columns(1) = ""
    
31.    Sheets(1).Range("a1").Resize(k) = brr
    
32.    Sheets(1).[a1].Select
    
33. End Sub
    
34. 
    

复制代码

跳转到最佳答案楼层

yyyydddd8888

请测试：

取数.zip (479.27 KB, 下载次数: 3)

2013-12-22 16:51 上传

点击文件名下载附件

1. Sub 提取()
   
2. Dim arr, brr(1 To 10000, 1 To 1), d As Object, i&, j&, k&
   
3. Dim d1 As Object, temp
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d1 = CreateObject("scripting.dictionary")
   
6. For i = 1 To 5
   
7.     arr = Sheets(i).Range("k3:k1000")
   
8.     For j = 1 To UBound(arr)
   
9.           d(arr(j, 1)) = d(arr(j, 1)) + 1
   
10.     Next j
    
11.           temp = d.keys
    
12.     For j = 1 To d.Count
    
13.         If d(temp(j - 1)) > 2 And temp(j - 1) <> "" Then
    
14.         k = k + 1
    
15.         brr(k, 1) = temp(j - 1)
    
16.         End If
    
17.     Next j
    
18.           d.RemoveAll
    
19. Next i
    
20.    For i = 1 To k
    
21.        d1(brr(i, 1)) = ""
    
22.    Next i
    
23.    Sheets(1).Columns(1) = ""
    
24.    Sheets(1).Range("a1").Resize(d1.Count) = Application.Transpose(d1.keys)
    
25. End Sub
    
26. 
    

复制代码

yyyydddd8888

如果要按工作表的中数据出现的先后顺序提取的话，可以用下面的代码：
取数.rar (263.18 KB, 下载次数: 0)

2013-12-22 17:02 上传

点击文件名下载附件

1. Sub 提取()
   
2. Dim arr, brr(1 To 10000, 1 To 1), d As Object, i&, j&, k&
   
3. Dim d1 As Object, temp
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d1 = CreateObject("scripting.dictionary")
   
6. For i = 1 To 5
   
7.     arr = Sheets(i).Range("k3:k1000")
   
8.     For j = 1 To UBound(arr)
   
9.           d(arr(j, 1)) = d(arr(j, 1)) + 1
   
10.     Next j
    
11.           temp = d.keys
    
12.     For j = 1 To d.Count
    
13.         If d(temp(j - 1)) > 2 And temp(j - 1) <> "" Then
    
14.         k = k + 1
    
15.         brr(k, 1) = temp(j - 1)
    
16.         End If
    
17.     Next j
    
18.           d.RemoveAll
    
19. Next i
    
20.    For i = 1 To k
    
21.        If Not d1.exists(brr(i, 1)) Then
    
22.           d1(brr(i, 1)) = ""
    
23.        End If
    
24.    Next i
    
25.    Sheets(1).Columns(1) = ""
    
26.    Sheets(1).Range("a1").Resize(d1.Count) = Application.Transpose(d1.keys)
    
27.    Sheets(1).[a1].Select
    
28. End Sub
    
29. 
    

复制代码

lkjhuy

yyyydddd8888 发表于 2013-12-22 17:02
如果要按工作表的中数据出现的先后顺序提取的话，可以用下面的代码：

但每个表k3:k1000里有重数的话只能算一个

yyyydddd8888

lkjhuy 发表于 2013-12-22 17:03
但每个表k3:k1000里有重数的话只能算一个

是的，只算了一个。你测试一下。

lkjhuy

yyyydddd8888 发表于 2013-12-22 17:03
是的，只算了一个。你测试一下。

例结果021,它只在表1和表4有不大于2呀

yyyydddd8888

是不是这样？
你是要提取同一数字在大于2个工作表中出现的数据吗？如果是这样，请用这一个附件：
取数.zip (482.97 KB, 下载次数: 1)

2013-12-22 17:13 上传

点击文件名下载附件

lkjhuy

yyyydddd8888 发表于 2013-12-22 17:13
是不是这样？
你是要提取同一数字在大于2个工作表中出现的数据吗？如果是这样，请用这一个附件：

打不开zip文件直上代码吧

yyyydddd8888

lkjhuy 发表于 2013-12-22 17:26
打不开zip文件直上代码吧

传一个rar:
取数.rar (264.58 KB, 下载次数: 2)

2013-12-22 17:34 上传

点击文件名下载附件

1. Sub 提取()
   
2. Dim arr, brr(1 To 10000, 1 To 1), d As Object, i&, j&, k&
   
3. Dim d1 As Object, temp
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d1 = CreateObject("scripting.dictionary")
   
6. For i = 1 To 5
   
7.     arr = Sheets(i).Range("k3:k1000")
   
8.     For j = 1 To UBound(arr)
   
9.           d(arr(j, 1)) = ""
   
10.     Next j
    
11.           temp = d.keys
    
12.     For j = 1 To d.Count
    
13.         k = k + 1
    
14.         brr(k, 1) = temp(j - 1)
    
15.     Next j
    
16.           d.RemoveAll
    
17. Next i
    
18.    For i = 1 To k
    
19.        d1(brr(i, 1)) = d1(brr(i, 1)) + 1
    
20.    Next i
    
21.        temp = d1.keys
    
22.        Erase brr
    
23.        k = 0
    
24.    For i = 1 To d1.Count
    
25.        If d1(temp(i - 1)) > 2 Then
    
26.         k = k + 1
    
27.         brr(k, 1) = temp(i - 1)
    
28.        End If
    
29.    Next i
    
30.    Sheets(1).Columns(1) = ""
    
31.    Sheets(1).Range("a1").Resize(k) = brr
    
32.    Sheets(1).[a1].Select
    
33. End Sub
    
34. 
    

复制代码

lkjhuy

yyyydddd8888 发表于 2013-12-22 17:33
传一个rar:

输出的数据中间为何有空格?