[已解决]多表格查找重复列并提取的VBA代码

mhyjcm8888

求助VBA代码！！！如附件1,2,3,4,5表格中都有一组横排数字，提取其数字相同的列，并把结果显示在第六表格中。 工作簿.rar (89.99 KB, 下载次数: 20)

2013-9-29 10:11 上传

点击文件名下载附件
谢谢各位！！！！！！！！！！

最佳答案

月排行榜 / 总排行榜

美斯特邦威

2013-10-4 11:19

mhyjcm8888 发表于 2013-10-4 10:16
能否帮忙修改一下，谢谢！！！

1. Sub abc()
   
2. Set d = CreateObject("scripting.dictionary")
   
3. Set d1 = CreateObject("scripting.dictionary")
   
4. For i = 1 To Sheets.Count - 1
   
5. kk = Sheets(i).Range("a15").CurrentRegion
   
6. For j = 1 To UBound(kk, 2)
   
7. s = Join(Application.Transpose(Application.Index(kk, 0, j)))
   
8. d1(s) = ""
   
9. Next j
   
10. pp = d1.keys
    
11. d1.RemoveAll
    
12. For j = 0 To UBound(pp)
    
13. d(pp(j)) = d(pp(j)) + 1
    
14. If d(pp(j)) = Sheets.Count - 1 Then
    
15. Cells(1, m + 1).Resize(4, 1) = Application.Transpose(Split(pp(j), " "))
    
16. m = m + 1
    
17. End If
    
18. Next j
    
19. Next i
    
20. End Sub

复制代码

跳转到最佳答案楼层

美斯特邦威

1. Sub abc()
   
2. Set d = CreateObject("scripting.dictionary")
   
3. For i = 1 To Sheets.Count - 1
   
4. kk = Sheets(i).Range("a15").CurrentRegion
   
5. For j = 1 To UBound(kk, 2)
   
6. s = Join(Application.Transpose(Application.Index(kk, 0, j)))
   
7. d(s) = d(s) + 1
   
8. If d(s) = Sheets.Count - 1 Then
   
9. Cells(1, m + 1).Resize(4, 1) = Application.Transpose(Split(s, " "))
   
10. m = m + 1
    
11. End If
    
12. Next j
    
13. Next i
    
14. End Sub

复制代码

这个意思？？？

mhyjcm8888

美斯特邦威 发表于 2013-9-29 10:39
这个意思？？？

是这个意思！！！谢谢[em23]

mhyjcm8888

美斯特邦威 发表于 2013-9-29 10:39
这个意思？？？

今天测试发现错误，很多不同的都选出来了

无聊的疯子

mhyjcm8888 发表于 2013-10-1 15:01
今天测试发现错误，很多不同的都选出来了

既然发现了错误，为啥不把这些数据所在位置说出来呢？？你是在出考题么？

mhyjcm8888

无聊的疯子 发表于 2013-10-2 13:35
既然发现了错误，为啥不把这些数据所在位置说出来呢？？你是在出考题么？

我哪有资格出考题啊，VBA我是菜鸟啦！！数据所在的位置我也不知道说明！！！我把附件发上来，你帮我看看是什么原因吧！里面第二个代码运行的时候提示下标越界不知道错在哪里，请你指点改正一下！！谢谢 工作簿.rar (94.68 KB, 下载次数: 8)

2013-10-2 16:46 上传

点击文件名下载附件

上清宫主

猜谜太难了

美斯特邦威

mhyjcm8888 发表于 2013-10-2 16:46
我哪有资格出考题啊，VBA我是菜鸟啦！！数据所在的位置我也不知道说明！！！我把附件发上来，你帮我看看是 ...

你那个t都是空值了，然后还用brr存取，当然是下标越界

mhyjcm8888

美斯特邦威 发表于 2013-10-4 10:04
你那个t都是空值了，然后还用brr存取，当然是下标越界

能否帮忙修改一下，谢谢！！！

美斯特邦威

mhyjcm8888 发表于 2013-10-4 10:16
能否帮忙修改一下，谢谢！！！

1. Sub abc()
   
2. Set d = CreateObject("scripting.dictionary")
   
3. Set d1 = CreateObject("scripting.dictionary")
   
4. For i = 1 To Sheets.Count - 1
   
5. kk = Sheets(i).Range("a15").CurrentRegion
   
6. For j = 1 To UBound(kk, 2)
   
7. s = Join(Application.Transpose(Application.Index(kk, 0, j)))
   
8. d1(s) = ""
   
9. Next j
   
10. pp = d1.keys
    
11. d1.RemoveAll
    
12. For j = 0 To UBound(pp)
    
13. d(pp(j)) = d(pp(j)) + 1
    
14. If d(pp(j)) = Sheets.Count - 1 Then
    
15. Cells(1, m + 1).Resize(4, 1) = Application.Transpose(Split(pp(j), " "))
    
16. m = m + 1
    
17. End If
    
18. Next j
    
19. Next i
    
20. End Sub

复制代码