他のExcelブックをSQLでデータ抽出する

Sub test()
'1:ADOを有効にするにはVBEの[参照設定]より[Microsoft ActiveX Date Objects 2.8 Library]にチェックﾏｰｸを入れる
'2:データベースとなるワークブックは、元のワークブックと同じフォルダに入っているものとする

　Dim myAns As String
　myAns = "xxxxx" 'xxxxx　には納品先項目にある抽出する名称　→　フォームなどで選択すると○

　Dim i As Long, k As Long 'iは書き込む行の位置　kは書き込む列の位置
　Dim buf As String

　Dim dbCon As ADODB.Connection
　Dim dbRes As ADODB.Recordset

　Const cnsProvider = "Microsoft.Jet.OLEDB.4.0"
　Const cnsExtProp = "Extended Properties"
　Const cnsExcel = "Excel 8.0"
　Const cnsDBName = "testBook.xls" 'ブック名（外部データ）

　Set dbCon = New ADODB.Connection

　With dbCon
　　 .Provider = cnsProvider
　　 .Properties(cnsExtProp) = cnsExcel
　 　 .Open ThisWorkbook.Path & "\" & cnsDBName '取得するブックのパスを取得
　End With

　 ' SQL文作成
　'strSQL = "SELECT * FROM [Sheet1$]" ' 全件抽出
　strSQL = "SELECT * FROM [Sheet1$] WHERE 納品先= '" & myAns & "'"

　 'RecordSet取得
　 Set dbRes = New ADODB.Recordset
　 dbRes.CursorLocation = adUseClient

　 'SQLを実行
　 dbRes.Open strSQL, dbCon, adOpenDynamic, adLockOptimistic, adCmdText

　 ' 見出し作成
　 Cells.Clear '表記するシートのセルをクリア
　 For k = 1 To dbRes.Fields.Count
　　 Cells(1, k).Value = dbRes.Fields(k - 1).Name
　 Next k

　 ' 明細書き出し
　 i = 2
　 Do While Not dbRes.EOF
　　 For k = 1 To dbRes.Fields.Count
　　　 Cells(i, k).Value = dbRes.Fields(k - 1).Value
　 Next k
　 dbRes.MoveNext
　 i = i + 1
　 Loop

　 ' 終了処理
　 dbRes.Close: Set dbRes = Nothing
　 dbCon.Close: Set dbCon = Nothing
End Sub