Sub 查找数据()
Application.ScreenUpdating = False '屏幕刷新关
Workbooks.Open ("C:\Users\pc\Desktop\数据查找\数据源.xlsx") '打开数据源表格,自己改位置和名称
Dim sh1 As Worksheet, sh2 As Worksheet
Dim r%, i%, j%
Dim rng As Range
Set sh1 = Workbooks("数据源.xlsx").Worksheets(1) '命名数据源表格工作表1,自己改数据源工作部的名称和工作表序号
Set sh2 = ThisWorkbook.Worksheets(1) '查找数据放在工作表1了,自己改序号
r = sh1.Range("d1048576").End(xlUp).Row
a = sh2.Range("d1048576").End(xlUp).Row
b = sh2.Range("f1048576").End(xlUp).Row + 1
For i = b To a
c = sh1.Range("d:d").Find(sh2.Range("d" & i).Text).Row '查找D列要查询的项,在数据源工作簿中的行号
sh1.Range("d" & c & ":f" & c).Copy sh2.Range("d" & i) '复制过去
Next i
Workbooks("数据源.xlsx").Close savechanges:=False '关闭数据源表格,不保存,运行前自己注意
Application.ScreenUpdating = True '屏幕刷新开
End Sub