[已解决]求vb

lkjpoi

Book1.rar (69.62 KB, 下载次数: 12)

2013-12-5 14:50 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

sliang28

2013-12-5 16:35

附件请查收
........................

跳转到最佳答案楼层

sliang28

附件请查收
........................

lkjpoi

sliang28 发表于 2013-12-5 16:35
附件请查收
........................

我只要1到3表的结果,而且全放表1a列

大灰狼1976

附件请测试

1. Private Sub CommandButton1_Click()
   
2. Dim arr, ar, brr(1 To 1000), sh&, d As Object, n&, m&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. For sh = 1 To 3
   
5.   n = Sheets(sh).[b1]
   
6.   arr = Sheets(sh).[g3].CurrentRegion
   
7.   For Each ar In arr
   
8.     d(ar) = d(ar) + 1
   
9.   Next ar
   
10.   d.Remove ""
    
11.   For Each ar In d.keys
    
12.     If d(ar) = n Then m = m + 1: brr(m) = ar
    
13.   Next ar
    
14.   d.RemoveAll
    
15. Next sh
    
16. [a1].Resize(UBound(brr)) = Application.Transpose(brr)
    
17. End Sub

复制代码