Access2000のVBAで上書き更新

質問

お世話になります。
Access2000のVBAで作成しております。

Ｅｘｃｅｌに記載した情報をAccessのテーブルに
取り込むために下記のソースを作成致しました。

既にテーブルに主キーが重複しないものを取り込むときは
正常に処理が走るのですが、
主キーが重複する場合は、重複する旨メッセージを出して
処理が止まります。

どのようにソースを修正すれば、「主キーが重複する場合、上書き更新」
するように処理が走るのでしょうか？

以上宜しくお願い致します。
--------------ソース------------------------------
Dim rs As New ADODB.Recordset
Dim oApp As Object
Dim iRow As Long

Set oApp = CreateObject("Excel.Application")
oApp.Workbooks.Open Filename:="hogehoge.xls"

rs.Open "テーブル", CurrentProject.Connection, adOpenForwardOnly, adLockOptimistic
iRow = 2 ' ★
While(　ループ　)
　　rs.AddNew
　　rs("ID") = oApp.Cells(iRow, 1)
　　rs("名前") = oApp.Cells(iRow, 2)
　　rs.Update
　　iRow = iRow + 1
Wend
rs.Close
oApp.Quit
Set oApp = Nothing

回答No.1

30246kiku · ベストアンサー

Excel から取り込む際
・重複・・・これはIDで、Excelデータ内には重複したIDは存在しない
・前に取り込んだものも、まだ Excel にデータとして入っている

Excel の１行目には、テーブルのフィールド名と同じ項目が設定されている・・・
テーブル名を「T3」
これを条件に、以下を記述し実行してみます。

Public Sub testImport()
　　Dim sSql As String

　　sSql = "UPDATE T3 RIGHT JOIN [Excel 8.0;HDR=YES;IMEX=1;DATABASE={%2}].[{%1}] AS Q1 " _
　　　　　　& "ON T3.ID = Q1.ID SET T3.ID = Q1.ID, T3.氏名=Q1.氏名 " _
　　　　　　& "WHERE T3.ID Is Null;"
　　sSql = Replace(sSql, "{%1}", "Sheet1$") ' 対象のシート名 + $
　　sSql = Replace(sSql, "{%2}", "E:\Excel\hogege\hogehoge.xls") ' 対象ファイルのパス
　　CurrentProject.Connection.Execute sSql
End Sub

これは、テーブル「T3」の「ID」と、Excel ファイル hogehoge.xls の Sheet1 のIDとを
外部結合して、（Excel側全部とT3にあったら）その結果 T3.ID が Null であれば、
Excel側にしか存在しないものになるので、ID、氏名を設定するものになります。

※ ID に変更はなく、氏名が変わる事があれば
　WHERE T3.ID Is Null 部分を削除することで対応できると思います。

なお、上記では UPDATE 文を使いましたが、INSERT に変更しても良いかも
未検証ですが、雰囲気以下の様な感じで

INSERT INTO T3(ID, 氏名）
SELECT ID, 氏名 FROM [Sheet1$] IN 'E:\Excel\hogege\hogehoge.xls'[Excel 8.0;HDR=YES;IMEX=1;]
WHERE NOT EXISTS (SELECT 1 FROM T3 WHERE ID=[Sheet1$].ID);

ここでは EXISTS を使ってみましたが、前述の様に外部結合を使っても良いかも

提示のあった記述で対応するとすれば、
・ On Error Resume Next でエラーを無視する
・ On Error GoTo ERR_HND として、 ERR_HND 部分でエラー番号を判別し
　　重複・・・なら UpdateCancel してから Resume Next するとか
IDが重複した場合でも、氏名を更新したい・・・であれば、未検証ですが以下の様な雰囲気
（ ID は数値型とした場合 ）

　　rs.Open "テーブル", CurrentProject.Connection, adOpenStatic, adLockOptimistic
　　iRow = 2
　　While (ループ)
　　　　rs.Filter = "ID=" & oApp.Cells(iRow, 1)
　　　　If (rs.EOF) Then
　　　　　　rs.AddNew
　　　　　　rs("ID") = oApp.Cells(iRow, 1)
　　　　End If
　　　　rs("名前") = oApp.Cells(iRow, 2)
　　　　rs.Update
　　　　iRow = iRow + 1
　　Wend

Filter で ID が存在するか絞り込んでから、なかったら AddNew
Filter を使ってますが、遅かったら・・・ Find にしてみるとか・・・・

参考にする/しないは、自己責任にてお願いします。

お礼

いけました！！！！

本当にありがとうございます！！