VBAのfor next で繰り返しが出来ず・・・

すいません1つ質問があります。

以前質問させて頂きましたが、ExcelのVlookupでACCESSのクエリを参照してレコードを取得したいです。

ADOでAccessのテーブルから持ってくることは出来ました。
が、繰り返しても最初の数字の9999しかもって来ません・・・。

下記が私の書いたコードとなります。
ExcelシートとACCESSテーブルを画像として添付します。
D2には9999、D3には55555・・・・と持ってくるようにしたいです。


原因と修正法を教えて頂ければ幸いです。

何卒よろしくお願いします。

Option Explicit
Sub test()
Dim db As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strSQL As String
Dim i As Long
Dim Maxrow As Long

Set db = New ADODB.Connection
db.Provider = "Microsoft.ace.oledb.12.0"
db.Open "C:\Users\Kei\Desktop\Test\Test.accdb"

Set rs = New ADODB.Recordset
rs.Open "Ship", db, adOpenStatic

Maxrow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To Maxrow

strSQL = "select * from Ship where 商品名 =" & Cells(i, 1) & ";"

Cells(i, 4) = rs!出荷数

Next i

rs.Close
db.Close
Set db = Nothing
Set rs = Nothing

End Sub

No.2 回答者： mitarashi 回答日時： 2014/04/23 00:56

#1です。

xl2010/Acc2010で動作確認してから投稿しております。
Test.accdbをデスクトップに置いて実行すれば、そのままコピペして動作する筈です。
実行結果と、テーブルの情報を画像で添付いたします。
ご確認下さい。

No.1 回答者： mitarashi 回答日時： 2014/04/20 23:35

rs.Open "Ship", db, adOpenStatic で、テーブル丸ごと開いていて、

strSQL = "select * from Ship where 商品名 =" & Cells(i, 1) & ";"　が、意味をなしていませんね。

下記testの様に、ループの中で都度SQLを指定してRecordsetを取得するか、
test2の様に、テーブル丸ごと取得しておいて、フィルターで絞り込むかどちらかでしょう。
ご参考まで。
※試験のためのパスが違っていますので、そのまま貼り付けても駄目ですのでご注意下さい。
また、記載漏れかもしれませんが、文字列型での抽出の場合はシングルクォーテーションで囲ってやる必要がありますので、念のため。

Sub test()
Dim db As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strSQL As String
Dim i As Long
Dim Maxrow As Long

Set db = New ADODB.Connection
db.Provider = "Microsoft.ace.oledb.12.0"
db.Open GetDesktopPath & "\Test.accdb"
Set rs = New ADODB.Recordset
Maxrow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To Maxrow
strSQL = "select * from Ship where 商品名 ='" & Cells(i, 1) & "';"
rs.Open strSQL, db, adopenstatic
Cells(i, 4) = rs!出荷数
rs.Close
Next i

If rs.State = 1 Then rs.Close 'adStateOpen=1
db.Close
Set db = Nothing
Set rs = Nothing
End Sub

Sub test2()
Dim db As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strSQL As String
Dim i As Long
Dim Maxrow As Long

Set db = New ADODB.Connection
db.Provider = "Microsoft.ace.oledb.12.0"
db.Open GetDesktopPath & "\Test.accdb"
Set rs = New ADODB.Recordset
rs.Open "Ship", db, adopenstatic
Maxrow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To Maxrow
rs.Filter = "商品名 ='" & Cells(i, 1) & "'"
Cells(i, 4) = rs!出荷数
rs.Filter = ""
Next i

rs.Close
db.Close
Set db = Nothing
Set rs = Nothing
End Sub

Private Function GetDesktopPath() As String
Dim wScriptHost As Object, strInitDir As String
Set wScriptHost = CreateObject("Wscript.Shell")
GetDesktopPath = wScriptHost.SpecialFolders("Desktop")
Set wScriptHost = Nothing
End Function

この回答への補足

アドバイスありがとうございます。

1番目を試したところ、やはり、全て9999でした・・・。

1番目のやり方だときちんとFor nextが機能せず、"りんご"のみを参照し続ける用に思えます。
何とかここをクリアしたいのですがアドバイス頂けますか？

何卒よろしくお願いします。

補足日時：2014/04/22 23:23