Microsoft Access 掲示板

Sub Test3()

    Dim DBpath As String
    Dim adoCn As Object
    Dim strSQL As String

    Set adoCn = CreateObject("ADODB.Connection")
    DBpath = ThisWorkbook.Path & "\tes.accdb"
    adoCn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DBpath & ";"
       Dim i As Long
       i = 2

       With rs
       Do Until Cells(i, 1) = ""

       strSQL = "UPDATE MT_社員 SET 身長='" & Cells(i, 3) & "WHERE ID=" & Cells(i, 1).Value & ""

      Loop
      End With
      adoCn.Execute strSQL 'SQLを実行

    adoCn.Close
    Set adoCn = Nothing

End Sub

ExcelのVBAから、ACCESSのフィールドを更新したいのです。
MT_社員の構造
ID⇒主キー
名前⇒文字型
身長⇒数値型

このようになっています。
ACCESSでは、身長が空欄です。

Excelには、ID、名前、身長が入力されています。
IDに基づいて、身長のフィールドを更新したいのです。

上記のコードを実行すると、無限ループなのでしょうか？
処理が終わりません。

お手数ですが、ご教示をお願いします。