SQLServer のテーブルを、ACCESSにコピーする（ADOで１行ずつコピー）

SQLServer のテーブルを、ACCESSにコピーするにあたり、SELECT INTO というSQL文一発で実行できて便利だ！　と書いたのですが、、、

テーブルによっては以下のようなエラーが出て、どうにもならない例がありました。











いろいろと試行錯誤したのですが、SQL文一発では解決できそうになく、、、
ADOを使って、チマチマ１行ずつ読み書きするという古来の方法しか無いのかな。。。

せめて、プロシージャにしておくか。

・読むADOコネクションを開く（SQLServerから）
・書くADOコネクションを開く（Accessへ）
・Call TableImport("読み書きするテーブル名", 読むADO, 書くADO)

こんな感じで使えます。
案外、思ったよりも処理が早い！

Option Compare Database

' ■--------------------------------------------------------
' ■SQLServer のテーブルを、ACCESSにコピーする
' ■--------------------------------------------------------
Public Sub GetTableDWH()

    Dim strSQL As String
    Dim strMessage As String
    
    ' ■SQLServerから読み込む側の設定
    Dim adoCn_R As Object 'ADOコネクションオブジェクト
    Set adoCn_R = CreateObject("ADODB.Connection") 'ADOコネクションのオブジェクトを作成
    adoCn_R.Open = "Provider=SQLOLEDB.1;Password=パスワード;Persist Security Info=True;User ID=ユーザー名;Initial Catalog=データベース名;Data Source=サーバー名"

    ' ■Accessへ書き込む側の設定
    Dim adoCn_W As Object 'ADOコネクションオブジェクト
    Set adoCn_W = CurrentProject.Connection
    
    ' ■テーブルを読み込む処理（ここでは、同じテーブル名での読み書きを想定しています）
    Call TableImport("読み書きするテーブル名", adoCn_R, adoCn_W)

    ' ■読み書きの設定を終了する
    adoCn_R.Close: Set adoCn_R = Nothing 'コネクションの破棄
    adoCn_W.Close: Set adoCn_W = Nothing 'コネクションの破棄

    MsgBox "取り込み処理が完了しました！" & vbCrLf & vbCrLf & strMessage
    
End Sub

' ■--------------------------------------------------------
' ■SQLServer のテーブルを、ACCESSにコピーする
' ■--------------------------------------------------------
Private Sub TableImport(strTableName As String, ByRef objCn_R As Object, ByRef objCn_W As Object)

    ' SQLServerから読み込む側の設定
    Dim adoRs_R As Object 'ADOレコードセットオブジェクト
    Set adoRs_R = CreateObject("ADODB.Recordset") 'ADOレコードセットのオブジェクトを作成

    ' Accessへ書き込む側の設定
    Dim adoRs_W As Object 'ADOレコードセットオブジェクト
    Set adoRs_W = CreateObject("ADODB.Recordset") 'ADOレコードセットのオブジェクトを作成
    
    ' 削除メッセージを出さなくして、Access上のテーブル内容を全件削除
    DoCmd.SetWarnings False
    DoCmd.RunSQL "DELETE FROM " & strTableName
    
    ' Access側のテーブルが、クリアされて無かったら、エラー表示
    If DCount("*", strTableName) > 0 Then
        MsgBox "Access側の「" & strTableName & "」テーブルの内容、削除しきれてないでー"
    End If
        
    ' SQLserver側のテーブル内容を全件持ってくるため、読み込み、書き込みのオープン
    strSQL = "SELECT * FROM " & strTableName
    adoRs_R.Open strSQL, objCn_R
    adoRs_W.Open strTableName, objCn_W, 1, 2
    
    ' レコードごとに読み書きし、全レコードをなめる
    Do Until adoRs_R.EOF
        adoRs_W.AddNew
        For i = 0 To adoRs_R.Fields.Count - 1
            adoRs_W.Fields(i).Value = adoRs_R.Fields(i).Value
        Next i
        adoRs_W.Update
        adoRs_R.MoveNext
    Loop
    
     'レコードセットの破棄
    adoRs_R.Close: Set adoRs_R = Nothing
    adoRs_W.Close: Set adoRs_W = Nothing

    ' メッセージを出すモードに戻す
    DoCmd.SetWarnings True

End Sub