[已解决]求助，如何遍历工作表获取所需？

ckoeng

工作中遇到的问题，需要查询的内容实在太多了，做了个简单的例子，希望有高手能帮忙写段代码，感激不尽~~！！

需求：

A2填入名称后，从“数据源”获取对应的“编号”、“规格”、“实际规格”，再根据所获取的“编号”获取所有的“批量”(如附件“查询”左侧所示)

批量有重复的，若重复只显示一个即可，如附件“查询”左侧J列为aa对应的批量，实际显示只需像I列即可

数据源说明：实际应用时数据存在于约20个工作表中，工作表名称没有规律，每个工作表中数据约2000个，附件“数据源”为其简单例子

最佳答案

月排行榜 / 总排行榜

dsmch

2015-7-28 17:14

1. Sub Macro1()
   
2. Dim arr, s&, i%, j&, mc
   
3. Application.ScreenUpdating = False
   
4. mc = [a2]: [e2:i2000].ClearContents: s = 1
   
5. With GetObject(ThisWorkbook.Path & "\数据源.xls")
   
6.     For i = 1 To .Sheets.Count
   
7.         arr = .Sheets(i).Range("a1").CurrentRegion
   
8.         For j = 2 To UBound(arr)
   
9.             If arr(j, 1) = mc Then
   
10.                 s = s + 1
    
11.                 Cells(s, 5) = arr(j, 3)
    
12.                 Cells(s, 7) = arr(j, 5)
    
13.                 Cells(s, 8) = arr(j, 6)
    
14.                 Cells(s, 9) = arr(j, 13)
    
15.             End If
    
16.         Next
    
17.     Next
    
18.     .Close 0
    
19. End With
    
20. Application.ScreenUpdating = True
    
21. End Sub

复制代码

跳转到最佳答案楼层

dsmch

………………

ckoeng

dsmch 发表于 2015-7-27 22:23
………………

非常感谢你的帮助，可否在请你帮忙看看怎么解决如下问题：

因为实际使用时有一种特殊情况，数据源中的其中一个工作表内容比较特殊，其“名称”所对应的“编号”“规格”“实际规格”不是唯一的，最多有1个“名称”对3个“编号”“规格”“实际规格”；
而“编号”“规格”“实际规格”总是一对一的，可否通过填写“名称”获取所有对应的“编号”“规格”“实际规格”及所有“编号”所对应的所有“批量”？
ps.这种特殊情况可通过“名称”识别，且仅存在于一个工作表内

dsmch

1. Sub Macro1()
   
2. Dim arr, s&, i%, j&, mc
   
3. Application.ScreenUpdating = False
   
4. mc = [a2]: [e2:i2000].ClearContents: s = 1
   
5. With GetObject(ThisWorkbook.Path & "\数据源.xls")
   
6.     For i = 1 To .Sheets.Count
   
7.         arr = .Sheets(i).Range("a1").CurrentRegion
   
8.         For j = 2 To UBound(arr)
   
9.             If arr(j, 1) = mc Then
   
10.                 s = s + 1
    
11.                 Cells(s, 5) = arr(j, 3)
    
12.                 Cells(s, 7) = arr(j, 5)
    
13.                 Cells(s, 8) = arr(j, 6)
    
14.                 Cells(s, 9) = arr(j, 13)
    
15.             End If
    
16.         Next
    
17.     Next
    
18.     .Close 0
    
19. End With
    
20. Application.ScreenUpdating = True
    
21. End Sub

复制代码

ckoeng

dsmch 发表于 2015-7-28 17:14

非常感谢你，32个好评，谢谢