[已解决]VBA 根据条件匹配复制粘贴某个单元格和表名

cjl420949699

刚刚接触VBA，  不太懂。
想要实现根据Test1中的身份证信息，从Test2多个Sheet中查找匹配（身份证信息是唯一的），定位到数据后，把相对应的报名日期和表名（车型）填入到Test1中，不需要整行复制，最好是设定成自动循环的，就是我可以添加一个按钮，点击按钮会把Test1中的C列中填有的数据全部匹配，就算现在C列只有4行，新增到9行也可以匹配的样子，O(∩_∩)O谢谢

Test.rar (17.37 KB, 下载次数: 18)

2017-4-25 10:38 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2017-4-25 11:01

1. Sub aaa()
   
2. Dim arr, i&, sh As Worksheet, rng As Range
   
3. arr = [a1].CurrentRegion
   
4. Application.ScreenUpdating = False
   
5. Workbooks.Open ThisWorkbook.Path & "\test2.xlsx"
   
6. For i = 2 To UBound(arr)
   
7.   If arr(i, 3) <> "" Then
   
8.     For Each sh In Worksheets
   
9.       Set rng = sh.Cells.Find(arr(i, 3), lookat:=xlWhole)
   
10.       If Not rng Is Nothing Then Exit For
    
11.     Next sh
    
12.     arr(i, 4) = rng.Offset(, -1)
    
13.     arr(i, 5) = sh.Name
    
14.   End If
    
15. Next i
    
16. ActiveWorkbook.Close
    
17. [a1].CurrentRegion = arr
    
18. Application.ScreenUpdating = True
    
19. End Sub

复制代码

跳转到最佳答案楼层

大灰狼1976

1. Sub aaa()
   
2. Dim arr, i&, sh As Worksheet, rng As Range
   
3. arr = [a1].CurrentRegion
   
4. Application.ScreenUpdating = False
   
5. Workbooks.Open ThisWorkbook.Path & "\test2.xlsx"
   
6. For i = 2 To UBound(arr)
   
7.   If arr(i, 3) <> "" Then
   
8.     For Each sh In Worksheets
   
9.       Set rng = sh.Cells.Find(arr(i, 3), lookat:=xlWhole)
   
10.       If Not rng Is Nothing Then Exit For
    
11.     Next sh
    
12.     arr(i, 4) = rng.Offset(, -1)
    
13.     arr(i, 5) = sh.Name
    
14.   End If
    
15. Next i
    
16. ActiveWorkbook.Close
    
17. [a1].CurrentRegion = arr
    
18. Application.ScreenUpdating = True
    
19. End Sub

复制代码

cjl420949699

大灰狼1976 发表于 2017-4-25 11:01

万分感谢