- 締切済み
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 -----------------------------------------
- kgyqk433
- お礼率27% (220/805)
- Visual Basic
- 回答数3
- ありがとう数1
- みんなの回答 （3）
- 専門家の回答
みんなの回答
- mu_tsu_ki
- ベストアンサー率19% (10/51)
データの件数やテーブルのカラム定義等の条件により、 処理速度が変わる場合があります。 この質問には、上記のような詳細情報が欠如しているため、 「処理速度が速くなるような、別のコーディング」があるか どうかは不明です。
- ShowMeHow
- ベストアンサー率28% (1424/5027)
全部の処理をするのに、5秒かかっているのを長すぎると感じておられるのか、 30秒なのか、3分以上かかるから長すぎると考えているのか、、、 そのあたりをお聞きしたかったわけです。 質問の回答者は、あなたが何をやっているかを想像してどこに問題があるかを推測するわけですが、どうしても想像できないところもあるわけです。 それはさておき、データベースがらみの問題は、 ・コーディングの問題 ・ＳＱＬの組み方の問題 ・データベースのテーブルなどの構造の問題 ・データベースの性能の問題 ・コンピューターのスペックの問題 などが原因となり得ますので、コーディング方法だけで解決できないこともありえます。 今回の、インデックスと最適化は、まずテーブルの状況を適正にして見ましょうという話でした。 また、データの件数によってはアクセスで処理していること事態に無理があるのかもしれませんし、 すぐにＤＢの乗り換えなどを余儀なくされるかもしれませんし、その時点でゼロから作り直すなら、 後でもつかえる標準的な方法で組んだら良いのかなって話にもなるわけです。
補足
私の質問はこれです。 >処理速度が速くなるような、別のコーディングがあるのでしたら >教えて頂きたいので宜しくお願いします。
- ShowMeHow
- ベストアンサー率28% (1424/5027)
コーディングの問題については良くわかりませんが、まず以下の2項目をご確認ください。 1. [ID]が主キーもしくはインデックスとして登録されていることを確認してください。 2. データが削除されることがあるなら、データベースの最適化を行なってください。 あと、こういう質問をするときは、 ・どのようなスペックのパソコンで、 ・何件程度テーブルから ・何件程度のデータをコピーしようとして、 ・どのくらい時間がかかっているのか を大体でよいので付加えていただけると、 問題がどこにあるのか想像しやすいかもしれません。
お礼
お返事ありがとうございます。 >1. [ID]が主キーもしくはインデックスとして登録されていることを確認してください。 インデックス登録していないので、試してみたいと思います。 >2. データが削除されることがあるなら、データベースの最適化を行なってください。 データの削除は、発生しないのですが、試してみたいと思います。 >あと、こういう質問をするときは、 >・どのようなスペックのパソコンで、 >・何件程度テーブルから >・何件程度のデータをコピーしようとして、 >・どのくらい時間がかかっているのか >を大体でよいので付加えていただけると、 >問題がどこにあるのか想像しやすいかもしれません。 私としては、上記の記載は無意味だと思います。 処理速度:50秒が2件=100秒 ならOKで 処理速度:50秒が100件=5000秒 だとNGという考え方でしょうか？ 私は、件数・パソコンのスペックにかかわらず、 処理速度:50秒の時点でNGだと思います。 処理速度:50秒が2件=100秒、処理速度:50秒が100件=5000秒 を 処理速度:5秒が2件=10秒、処理速度:5秒が100件=500秒 件数・パソコンのスペックにかかわらず、必要だと思います。
関連する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に取り込んでいます。 しかしながら、「取り込み開始」の箇所を >あと、アクセスのインサートはＳＱＬ一発のほうが早いと思う。 >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で上書き更新
お世話になります。 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
- ベストアンサー
- Visual Basic
- access ふたつのテーブル間でのデータ移動VB
win10 office365 accessのテーブルの table1のフィールド IDの数値を table2のフィールド ID （いずれも長整数型 数値型 重複あり 空白の許容なし） にコピーする操作ですが 幾度か お尋ねしてきていますが 今回 このやり方で やってみました http://www.mahoutsukaino.com/ac/ac2002/vba/vba16/v16.htm 以下のコードにおいて rs2.Update ここの部分が黄色くなって とまってしまいます しかし なぜか 数値の移行は 出来ていました ただ止まってしまうと 次に続けられなく困っています Public Function table2table1() Dim cn As adodb.Connection Dim rs1 As adodb.Recordset Dim rs2 As adodb.Recordset Set cn = Application.CurrentProject.Connection Set rs1 = New adodb.Recordset Set rs2 = New adodb.Recordset rs1.Open "table1", cn, adOpenStatic, adLockReadOnly rs2.Open "table2", cn, adOpenKeyset, adLockOptimistic rs1.MoveFirst Do Until rs1.EOF rs2.Find "ID='" & rs1!ID & "'" If rs2.EOF Then rs2.AddNew rs2![ID] = rs1![ID] rs2.Update End If rs1.movenext Loop rs1.Close rs2.Close cn.Close End Function 以上 すみません 宜しくお願い致します
- ベストアンサー
- Access（アクセス）
- ADOでレコードを閉じるタイミング。。Access2000/VB6/Win2K
レコードセットを返すFuncitonプロシージャーを作ってみたのですが。。。 下のGet_Recordsの方のレコードセットをCloseすると上の方のDisp_Dataでオブ ジェクトが閉じているといって怒られます。しかし、閉じないと下の方では開きっ ぱなしになると思うのですが。。。どのように処理すればいいのでしょうか？ Public P_CN As ADODB.Connection Private Sub Disp_Date() Dim RS As ADODB.Recordset Dim SQL AS String Set RS = Get_Records(SQL) With RS If .RecordCount > 0 Then .MoveLast: .MoveFirst .Debug.Print !顧客_ID End If End With RS.Close Set RS = Nothing End Sub Public Function Get_Records(pSQL As String) As ADODB.Recordset Dim RS As ADODB.Recordset Set RS = New ADODB.Recordset RS.Open pSQL, P_CN, adOpenKeyset, adLockOptimistic Set Get_Records = RS ''' RS.Close ''' Set RS = Nothing End Function
- ベストアンサー
- その他(データベース)
- ExcelVBAでAccessのデータを検索する
Excel VBA で、ADOを用いてAccess のデータを検索するにはどうしたらいいですか。 やりたいこと 検索結果を、Excel のセルにコピーすること。 ソースコード 'MDBファイルに接続します Set db = New ADODB.Connection db.Provider = "Microsoft.Jet.OLEDB.4.0" db.Open "C:\Database\test.mdb" 'レコードセットを開きます Set rs = New ADODB.Recordset 'テーブルを開きます rs.Open "PT_MST", db, adOpenForwardOnly, adLockReadOnly findName = ws.Cells(i, 1) & ws.Cells(i, 2) Do ' rs.Find "[S_NUM]='" & findName & "'" rs.Find rs.Fields(1).name & " Like '20k%'" ← ここで、サポートしていない旨のエラーが出る。 If Not (rs.EOF) Then Debug.Print rs.Fields(1).Value Else Exit Do End If rs.MoveNext Loop Until rs.EOF '閉じる rs.Close db.Close '終了処理 Set rs = Nothing Set db = Nothing どう直したら、検出結果を取得できますか。 ご教示下さい。
- ベストアンサー
- Visual Basic
- ACCESSでExcelにデータ出力、高速化
ACCESSのVBAを使ってテーブルのデータを 既存ブックに出力し、別名で保存をしたいのですが、 どうも、処理が遅くて困っています。 改善点がありましたら教えてくださいお願いいたします。 Dim objExcel As Excel.Application Dim xlWrkbk As Excel.Workbook Dim xlWrksh As Excel.Worksheet Dim rs As DAO.Recordset Dim strFilename As String strFilename = CurrentProject.Path & "既存ブック名.XLS" Set objExcel = New Excel.Application Set xlWrkbk = objExcel.Workbooks.Open(Filename:=strFilename, ReadOnly:=True) Set xlWrksh = xlWrkbk.Worksheets("シート名") Set rs = CurrentDb.OpenRecordset("テーブル名", dbOpenSnapshot) With objExcel xlWrksh.Range("A:N").Clear xlWrksh.Range("A2").CopyFromRecordset rs xlWrkbk.SaveAs Filename:=CurrentProject.Path & "新しいブック名.xls" xlWrkbk.Close .Quit rs.Close End With Set rs = Nothing Set objExcel = Nothing Set xlWrkbk = Nothing Set xlWrksh = Nothing
- ベストアンサー
- その他（プログラミング・開発）
- 【Access】 郵便番号を検索するシステム
よろしくお願いいたします。 現在、Accessのフォームにて、任意の番号をテキストボックス("(1)")に入力し"検索ボタン"を押すと、該当する郵便番号がフォーム上のテキストボックス("(2)")に表示されるシステムを作っています。 また、郵便番号は"郵便番号一覧"というテーブルにまとめています。 (テーブルには約14万件の"郵便番号"と"住所"が含まれています) ここで質問があるのですが、同じ郵便番号であっても複数の住所が該当するケースがあります。 テーブルにもそうした件が多数含まれていますが、現在の私のVBAでは、その内のひとつの住所しか表示することが出来ません。 そこで、複数の住所が存在する場合は、該当する住所の一覧が表示され、その中から1件を選べるようなシステムを作りたく考えています。 様々な参考書を読み続けてきましたが、完全に行き詰まりました。お知恵を拝借頂けますと幸いです。 -------------------------------- 尚、現在のVBAは下記の通りです。 Private Sub 検索ボタン_Click() Dim db As DAO.Database Dim rs As DAO.Recordset Set db = CurrentDb Set rs = db.OpenRecordset("郵便番号一覧", dbOpenTable) With rs .Index = "郵便番号" .Seek "=", Me.(1) End With If Not rs.NoMatch Then With Me .(2) = rs!住所 End With End If rs.Close: Set rs = Nothing db.Close: Set db = Nothing End Sub
- ベストアンサー
- オフィス系ソフト
- アクセス2000VBA DAOをADOに書き換えてください
アクセス2000VBA DAOをADOに書き換えてください 下記プログラムをADOに書き換えてください。（DAT1、DAT2はモジュールにて定義してあります） Option Compare Database Dim DBS As Database Dim QDF As QueryDef Dim RST As DAO.Recordset Dim COUNT1 Private Sub Form_Load() On Error Resume Next DAT2 = [Forms]![伝票]![HAKKOU1] Set DBS = CurrentDb Set QDF = DBS.QueryDefs("発行") With QDF .Parameters("DAT1") = DAT2 ’もしかしたら DAT2 ではエラーがでるかもしれません。 Set RST = .OpenRecordset() ’正しい記述を教えてください .Close End With With RST COUNT1 = !指示書 .Close End With
- ベストアンサー
- オフィス系ソフト
- テーブルのレコードが0件時にmsg表示（アクセス）
とてつもない初歩的な質問で すみません！ フォーム1をメニュー画面として、 フォーム1にある「ボタン」を押すと テーブルにレコードが追加され、処理が走る・・・という仕様を作っています。 ですが、 このテーブルにレコードが追加されなかった＝0件 の場合の回避策を どうしたら良いのかが わかりません。 ちなみに、 Private Sub ボタン_Click() On Error GoTo errmsg DoCmd.SetWarnings False Dim DB As DAO.Database Dim rs1 As DAO.Recordset Dim rs2 As DAO.Recordset Dim i As Long Set DB = CurrentDb Set rs1 = DB.OpenRecordset("テーブル1") Set rs2 = DB.OpenRecordset("テーブル2", dbOpenDynaset) rs1.MoveFirst Do Until rs1.EOF If rs1!フィールドA1 = rs1!フィールドA2 Then rs2.AddNew rs2!ID = rs1!ID rs2!フィールドA = rs1!フィールドA1 rs2!B = rs1!フィールドB rs2!C = rs1!フィールドC rs2.Update End If If rs1!フィールドA1 < rs1!フィールドA2 Then For i = rs1!フィールドA1 To rs1!フィールドA2 Step 1 rs2.AddNew rs2!ID = rs1!ID rs2!フィールドA = i rs2!フィールドB = rs1!フィールドB rs2!フィールドC = rs1!フィールドC rs2.Update Next i End If rs1.MoveNext Loop rs1.Close: Set rs1 = Nothing rs2.Close: Set rs2 = Nothing DB.Close: Set DB = Nothing Call 次処理 errmsg: MsgBox "元データが未投入です。" End Sub としたのですが、 これでは データが投入され、処理が成功＝完了した場合にも エラーメッセージが出てしまいました。 ご教示いただけますと幸いです。 お手数をおかけしますが、よろしくお願い致します。
- ベストアンサー
- オフィス系ソフト
