Sub lqxs()

Dim conn, Sql$, Arr, i&, d, Arr1, aa

Set d = CreateObject("Scripting.Dictionary")

On Error GoTo 100

Set conn = CreateObject("adodb.connection")

conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.Path & "\总库存.xls"

Sql = "select * from [kucun$]"

Sheet1.Activate

Arr = conn.Execute(Sql).getrows

For i = 0 To UBound(Arr, 2)

If Not d.exists(Arr(1, i)) Then

d(Arr(1, i)) = Arr(2, i) & "," & Arr(7, i) & "," & Arr(8, i) & "," & Arr(11, i)

End If

Next

Arr1 = [a1].CurrentRegion

For i = 2 To UBound(Arr1)

If d.exists(Arr1(i, 2)) Then

aa = Split(d(Arr1(i, 2)), ",")

Cells(i, 3) = aa(0)

Cells(i, 5) = aa(1)

Cells(i, 6) = aa(2)

Cells(i, 7) = aa(3)

End If

Next

GoTo 200

100:

MsgBox "没有此数据！"

200:

[a2].Select

conn.Close

Set conn = Nothing

End Sub