Access2000のVBAで上書き更新
- Access2000のVBAを使用してExcelの情報をAccessのテーブルに取り込む方法を教えてください。
- 既にテーブルに主キーが重複する場合、上書き更新するVBAのソースコードを教えてください。
- Access2000のVBAでExcelからデータを取り込む際に発生する主キーの重複エラーを解決する方法を教えてください。
- ベストアンサー
Access2000のVBAで上書き更新
お世話になります。 Access2000のVBAで作成しております。 Excelに記載した情報を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
- kgyqk433
- お礼率27% (220/805)
- Visual Basic
- 回答数1
- ありがとう数1
- みんなの回答 (1)
- 専門家の回答
質問者が選んだベストアンサー
Excel から取り込む際 ・重複・・・これはIDで、Excelデータ内には重複したIDは存在しない ・前に取り込んだものも、まだ Excel にデータとして入っている Excel の1行目には、テーブルのフィールド名と同じ項目が設定されている・・・ テーブル名を「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 にしてみるとか・・・・ 参考にする/しないは、自己責任にてお願いします。
関連するQ&A
- Access2000のVBAコードの最適化
お世話になります。 Access2000のVBAでコードを作成したのですが、 処理をもっと早く出来る方法ありましたら教えて頂ければと 思います。 処理している内容としては、 (1)データ元のエクセルファイルを開く (2)エクセルファイルに記載されているセルの内容をAccessに挿入 ※取り込み開始・終了が200回程繰り返す ※While (oApp.Sheets(sheet).cells(iRow, 1) <> "")のループは500回程繰り返す 少しでも処理を速くする方法があれば教えて頂きたいので 宜しくお願い致します。 ------------ソース---------------- Set oApp = CreateObject("Excel.Application") oApp.Workbooks.Open FileName:=CurrentProject.Path & "\メイン.xlsm" ---------------取り込み開始------------- rs2.Open "選手", CurrentProject.Connection, adOpenForwardOnly, adLockOptimistic iRow = 2 sheet = "program" rs.Open "選手情報_選手ID", CurrentProject.Connection, adOpenForwardOnly, adLockOptimistic iRow = 2 ' ★ sheet = "program" While (oApp.Sheets(sheet).cells(iRow, 1) <> "") rs.Filter = "日=" & oApp.Sheets(sheet).cells(iRow, 2) rs.Filter = rs.Filter & " and 場=" & oApp.Sheets(sheet).cells(iRow, 1) rs.Filter = rs.Filter & " and 番号=" & oApp.Sheets(sheet).cells(iRow, 3) If (rs.EOF) Then rs.AddNew rs("日") = oApp.Sheets(sheet).cells(iRow, 2) rs("場") = oApp.Sheets(sheet).cells(iRow, 1) rs("番号") = oApp.Sheets(sheet).cells(iRow, 3) End If rs("1番") = oApp.Sheets(sheet).cells(iRow, 5) rs("2番") = oApp.Sheets(sheet).cells(iRow, 5 + 26) rs("3番") = oApp.Sheets(sheet).cells(iRow, 5 + 26 + 26) rs("4番") = oApp.Sheets(sheet).cells(iRow, 5 + 26 + 26 + 26) rs("5番") = oApp.Sheets(sheet).cells(iRow, 5 + 26 + 26 + 26 + 26) rs("6番") = oApp.Sheets(sheet).cells(iRow, 5 + 26 + 26 + 26 + 26 + 26) rs.Update iRow = iRow + 1 Wend rs.Close ---------------取り込み終了------------- ---------------取り込み開始------------- rs.Open "選手情報_選手名", CurrentProject.Connection, adOpenForwardOnly, adLockOptimistic iRow = 2 ' ★ sheet = "program" While (oApp.Sheets(sheet).cells(iRow, 1) <> "") rs.Filter = "日=" & oApp.Sheets(sheet).cells(iRow, 2) rs.Filter = rs.Filter & " and 場=" & oApp.Sheets(sheet).cells(iRow, 1) rs.Filter = rs.Filter & " and 番号=" & oApp.Sheets(sheet).cells(iRow, 3) If (rs.EOF) Then rs.AddNew rs("日") = oApp.Sheets(sheet).cells(iRow, 2) rs("場") = oApp.Sheets(sheet).cells(iRow, 1) rs("番号") = oApp.Sheets(sheet).cells(iRow, 3) End If rs("1番") = oApp.Sheets(sheet).cells(iRow, 1 + 5) rs("2番") = oApp.Sheets(sheet).cells(iRow, 1 + 5 + 26) rs("3番") = oApp.Sheets(sheet).cells(iRow, 1 + 5 + 26 + 26) rs("4番") = oApp.Sheets(sheet).cells(iRow, 1 + 5 + 26 + 26 + 26) rs("5番") = oApp.Sheets(sheet).cells(iRow, 1 + 5 + 26 + 26 + 26 + 26) rs("6番") = oApp.Sheets(sheet).cells(iRow, 1 + 5 + 26 + 26 + 26 + 26 + 26) rs.Update iRow = iRow + 1 Wend rs.Close ---------------取り込み終了-------------
- ベストアンサー
- Visual Basic
- Access2000にエクセルデータを取り込み
お世話になります。 Access2000のVBAを使用して エクセルにデータを取り込みたいと 思っています。 現在は、下記の(1)のソースで、エクセルのデータを Access2000に取り込んでいます。 しかしながら、「取り込み開始」の箇所を >あと、アクセスのインサートはSQL一発のほうが早いと思う。 >http://www.1keydata.com/jp/sql/sql-insert-into.php というアドバイスを頂きました。 しかしながら、私の知識がまったくなく、どのように コーディングしていいのかわからない状態です。 そこで、お手数でもうしわけございませんが、 下記の(1)のソースをSQLで使用した場合のコードを 教えて頂けないでしょうか? 私が馬鹿のため、ソースコードで頂きたいので、 ソースコードがわからないかたは、回答頂かなくて 結構ですのでよろしくおねがいいたします。 ------------ソース(1)---------------- Set oApp = CreateObject("Excel.Application") oApp.Workbooks.Open FileName:=CurrentProject.Path & "\メイン.xlsm" ---------------取り込み開始------------- rs2.Open "選手", CurrentProject.Connection, adOpenForwardOnly, adLockOptimistic iRow = 2 sheet = "program" rs.Open "選手情報_選手ID", CurrentProject.Connection, adOpenForwardOnly, adLockOptimistic iRow = 2 ' ★ sheet = "program" While (oApp.Sheets(sheet).cells(iRow, 1) <> "") rs.Filter = "日=" & oApp.Sheets(sheet).cells(iRow, 2) rs.Filter = rs.Filter & " and 場=" & oApp.Sheets(sheet).cells(iRow, 1) rs.Filter = rs.Filter & " and 番号=" & oApp.Sheets(sheet).cells(iRow, 3) If (rs.EOF) Then rs.AddNew rs("日") = oApp.Sheets(sheet).cells(iRow, 2) rs("場") = oApp.Sheets(sheet).cells(iRow, 1) rs("番号") = oApp.Sheets(sheet).cells(iRow, 3) End If rs("1番") = oApp.Sheets(sheet).cells(iRow, 5) rs("2番") = oApp.Sheets(sheet).cells(iRow, 5 + 26) rs("3番") = oApp.Sheets(sheet).cells(iRow, 5 + 26 + 26) rs("4番") = oApp.Sheets(sheet).cells(iRow, 5 + 26 + 26 + 26) rs("5番") = oApp.Sheets(sheet).cells(iRow, 5 + 26 + 26 + 26 + 26) rs("6番") = oApp.Sheets(sheet).cells(iRow, 5 + 26 + 26 + 26 + 26 + 26) rs.Update iRow = iRow + 1 Wend rs.Close ---------------取り込み終了------------- ---------------取り込み開始------------- rs.Open "選手情報_選手名", CurrentProject.Connection, adOpenForwardOnly, adLockOptimistic iRow = 2 ' ★ sheet = "program" While (oApp.Sheets(sheet).cells(iRow, 1) <> "") rs.Filter = "日=" & oApp.Sheets(sheet).cells(iRow, 2) rs.Filter = rs.Filter & " and 場=" & oApp.Sheets(sheet).cells(iRow, 1) rs.Filter = rs.Filter & " and 番号=" & oApp.Sheets(sheet).cells(iRow, 3) If (rs.EOF) Then rs.AddNew rs("日") = oApp.Sheets(sheet).cells(iRow, 2) rs("場") = oApp.Sheets(sheet).cells(iRow, 1) rs("番号") = oApp.Sheets(sheet).cells(iRow, 3) End If rs("1番") = oApp.Sheets(sheet).cells(iRow, 1 + 5) rs("2番") = oApp.Sheets(sheet).cells(iRow, 1 + 5 + 26) rs("3番") = oApp.Sheets(sheet).cells(iRow, 1 + 5 + 26 + 26) rs("4番") = oApp.Sheets(sheet).cells(iRow, 1 + 5 + 26 + 26 + 26) rs("5番") = oApp.Sheets(sheet).cells(iRow, 1 + 5 + 26 + 26 + 26 + 26) rs("6番") = oApp.Sheets(sheet).cells(iRow, 1 + 5 + 26 + 26 + 26 + 26 + 26) rs.Update iRow = iRow + 1 Wend rs.Close ---------------取り込み終了-------------
- 締切済み
- Visual Basic
- Access2000 VBA(ADO)を使用して主キーの空きを探す処理
「id」(文字型・8バイト)を主キーとした、簡単なテーブルを作成しました。 この「id」のフィールドには一応「KEY-0」~「KEY-10」まで入力されています。 (数字の部分は0,1,2,3,4,5・・・10となっています。) この主キーの空き(重複しない値)を探す処理を以下の様に作成しましたが、どうも上手いきません。 期待する主キーの空きは、「KEY-11」だと思うのですが、なぜか「KEY-10」で処理が抜けてしまいます。 ソフトウェア)Access2000 言語)VBA(ADOを使用しました。) 初歩的な事かもしれませんが、とても悩んでいます。 どなたかご教授いただけないでしょうか? 何卒、宜しくお願いします。 処理ここから Private Sub IdCheck_Click() Dim cn As ADODB.Connection Dim rs As ADODB.Recordset Dim i As Integer Dim TempKey as String Dim flgKey As Boolean Set cn = CurrentProject.Connection Set rs = New ADODB.Recordset rs.Open "TEST_TABLE", cn, adOpenKeyset, adLockOptimistic '各変数など初期化 TempKey = "" i = 0 flgKey = False '主キーの空きを探すまで処理を繰り返す。 Do TempKey = "KEY-" & CStr(i) rs.Find "id='" & TempKey & "'" '主キーの空きがあった場合 If rs.EOF Then '処理を終える flgKey = True '主キーの空きがない場合 Else i = i + 1 End If Loop Until flgKey = True '一応表示させて値の確認をしています。 MsgBox TempKey rs.Close Set rs = Nothing cn.Close Set cn = Nothing End Sub ここまで
- ベストアンサー
- その他(データベース)
- Accessのテーブル取り込み付いて
お世話になります。 Access2000のVBAで、テーブルの取り込み処理に ついて教えて下さい。 下記のようなソースで、ACCESSのテーブルを取り込み →エクセルに書き出しをしているのですが、 (1)の箇所で取り込み処理の時間が大量にかかっていることが わかりました。 処理速度が速くなるような、別のコーディングがあるのでしたら 教えて頂きたいので宜しくお願いします。 ----------ソース-------------------------- --------(1)--------------- With CurrentDb.QueryDefs(テーブル) .Parameters("[ID]") = "1111" Set rs = .OpenRecordset End With --------(1)--------------- If (Not rs.EOF) Then oApp.Sheets(1).cells(count, i + 1) = rs(i).Name oApp.Sheets(1).cells(count + 1, 1).CopyFromRecordset rs End If rs.Close Set rs = Nothing db.Close -----------------------------------------
- 締切済み
- Visual Basic
- VB6.0 の主キーの上書き処理について
いつもお世話になっております。 VisualBasic6.0の勉強をしています。 Text1、Text2、Commmand1 を配置したフォームを作成し、 Text1に番号、Text2に名前、を入力後、 Command1ボタンを押すと、 MySQLサーバにデータが登録される処理を作成しているのですが、 下記のプログラムでは登録は出来るのですが、 サーバ側で、主キーはText1で入力した番号にしているため、 サーバ側で登録済みの番号を入力し登録処理を行った際、 『実行時エラー'2147467259 プライマリー重複のエラーメッセージ』 が表示されます。 主キーを上書きする際は、どのような処理を加えればよいのでしょうか? Private Sub Command1_Click() Dim cn As ADODB.Connection Dim rs As ADODB.Recordset Set cn = New ADODB.Connection Set rs = New ADODB.Recordset Dim strTBL As Variant strTBL = "test" 'テーブル名 'Mysqlへ接続 cn.Open "Driver={MySQL ODBC 3.51 Driver};~略~ 'テーブルを開く rs.Open strTBL, cn, adOpenForwardOnly, adLockOptimistic, adCmdTable rs.AddNew '新規レコードを追加 rs!no = Text1.Text 'ナンバーをセット rs!Name = Text2.Text '名前をセット rs.Update '更新(保存) rs!no = Text1.Text 'ナンバーをセット rs!Name = Text2.Text '名前をセット cn.Close Set cn = Nothing Set rs = Nothing MsgBox "登録完了", vbOKOnly, "登録" Text1.Text = "" '登録後、テキストの内容を消去 Text2.Text = "" End Sub ご教示、よろしくお願いいたします
- 締切済み
- Visual Basic
- ACCESS VBA
ACCESSで検索フォームを作りたいと思っています。 VBAを使って行きたいと思うのですが、うまくいきません。 希望としては、該当するレコードのデータを抽出したいです。 よろしくお願いいたします。 ※現段階でのソースを書いてみました。 最終的に行いたい処理とは違うのですが、根本的に間違っているようなので簡略化しました。 /------------------------------------------------/ Private Sub コマンド1_Click() Dim cn As ADODB.Connection Dim rs As ADODB.Recordset Dim sql As String '接続 Set cn = CurrentProject.Connection 'レコードセットを取得 Set rs = New ADODB.Recordset sql = "SELECT * FROM 従業員データ " & _ "WHERE 年齢=30" rs.Open sql, cn, adOpenDynamic, adLockReadOnly rs.Close: Set rs = Nothing cn.Close: Set cn = Nothing End Sub /------------------------------------------------/
- ベストアンサー
- Visual Basic
- 【ACCESS2000】 VBAの更新処理に条件を加えたい。
下記のような更新処理のVBAを組みました。 これにIDが5のものを更新するというのを加えるには どうすればよいでしょうか。 Dim cn As ADODB.Connection Dim rs As New ADODB.Recordset Set cn = CurrentProject.Connection rs.Open "tbl_D_売上", cn, adOpenKeyset, adLockOptimistic, adCmdTableDirect rs("入金方法") = 2 rs("入金方法名称") = "分割" rs.Update rs.Close Set rs = Nothing cn.Close Set cn = Nothing
- ベストアンサー
- オフィス系ソフト
- Access VBAでExcel連携時のエラー(ワークシート指定時)
いつもお世話になっております。 現在、ExcelファイルのデータをAccessに取り込むVBでエラーが起こります。 (問題のおこる部分のみ、ソースを下記に記します。) ★の部分で、「実行時エラー1004 'Worksheets'メソッドは失敗しました:'_Global'オブジェクト」 というエラーが、出ます。 しかも、毎回ではなく、出たりでなかったりします。 これはなぜでしょうか? 定義の指定やappの指定に問題があるのでしょうか。 おわかりになる方がいらっしゃいましたら、ご指導願います。 宜しくお願いします。 --------------------------------------------------- Private Sub 取込み_Click() '■変数 Dim cn As ADODB.Connection Dim rs As ADODB.Recordset Dim app As Object Dim iRow As Long Dim iUsed As Long Dim iCnt As Long (中略) '■接続 Set cn = CurrentProject.Connection '■Excelアプリの起動及びファイルオープン Set app = CreateObject("Excel.Application") app.Workbooks.Open filename:=CurrentProject.Path & "\h.xls" '■レコードセットの取得 Set rs = New ADODB.Recordset rs.Open "マスタ", cn, adOpenForwardOnly, adLockOptimistic '■DBへのレコード追加 'h.xlsの取り込みスタート行設定 iRow = 13 ''h.xlsの最終使用行 取得および設定 iUsed = Worksheets(1).UsedRange.Rows.Count'★ 'MsgBox "使用行は" & iUsed & "です。" (以下略)。。。。
- ベストアンサー
- その他(データベース)
- ACCESS2013のVBAで、EXCELを操作
ご質問させて頂きます。 ACCESS2013のVBAで、EXCELを操作するために 下記のようにしています。 ------- Dim oApp As Object Dim oWkb As Object Dim oWks As Object Dim Rw As Integer Dim SQL As String Set oApp = CreateObject("Excel.Application") oApp.Visible = True oApp.DisplayAlerts = Flase '確認メッセージの非表示 ↓↓↓オートメーションエラー Set oWkb = oApp.Workbooks.Open(CurrentProject.Path & "\ひながた.xls") ------- 上記のところでオートメーションエラーになってしまいます。 しかし私の端末ではエラーは出ません。 問題と思われるのは エラーが出る人の端末は、 EXCELが2010と2013と 2つのバージョンがインストールされていることです。 このようなことでエラーが出てしまうことはあるのでしょうか?
- ベストアンサー
- その他([技術者向] コンピューター)
- Access クエリ抽出結果をExcel(特定フォーム)に出力させたい
いつもいつもお世話になっております(><) 今までこちらで色々質問しながら、 「条件入力フォームで入力した条件で、レコードを条件抽出し、この抽出結果をフォームに出力、かつ、伝票発行する」 というシステムを作っています。 今、伝票発行の部分で、下記のようなプロシージャを組みました。 そして、下記★(コード内参照)の2点で詰まっています。 ★1 指定しているクエリは抽出結果のフォームなのですが、これが「SQLステートメントが正しくありません」となります。どうしてでしょうか。ちなみに実在する別のクエリ名にすると、一応動きます。 ★2 フォーム上に抽出されたレコードがEOFになるまで、というループ条件にしたいのですが、この部分の記述は正しいでしょうか。 いつも初心者的質問で恐縮です。 どうぞよろしくお願い致します。 --------------------------------------------- Option Compare Database Private Sub 伝票発行_Click() Dim db As ADODB.Connection Dim rs As ADODB.Recordset Dim app As Object Dim wb As Excel.Workbook Dim iRow As Long Dim iColm As Long '■初期化 iRow = 12 iColm = 1 '■確認 If MsgBox("伝票を出力します。", vbOKCancel) = vbOK Then '■DBコネクション Set db = CurrentProject.Connection '■レコードセットの取得 Set rs = New ADODB.Recordset rs.Open "受注集計クエリ_f", db, adOpenStatic, adLockReadOnly '★1 '■Excelアプリの起動及びファイルオープン Set app = CreateObject("Excel.Application") app.Workbooks.Open filename:=CurrentProject.Path & "\nouhinsyo.xls" '■Excelシート名指定 app.Worksheets(1).Select Do Until rs.EOF '★2 ws.Cells(iRow, iColm + 2) = rs("品番") ws.Cells(iRow, iColm + 3) = rs("商品名") ws.Cells(iRow, iColm + 4) = rs("受注数の合計") ws.Cells(iRow, iColm + 8) = rs("備考") rs.MoveNext iRow = iRow + 1 Loop MsgBox "発行完了。" End If rs.Close app.Quit 'エクセルセッションをクローズする。 Set ws = Nothing '変数の初期化 Set wb = Nothing '変数の初期化 Set app = Nothing '変数の初期化 Set db = Nothing End Sub
- 締切済み
- その他(データベース)
お礼
いけました!!!! 本当にありがとうございます!!