Accessから値を抽出しようとするとフリーズする

このQ&Aのポイント
  • Excelからマクロを用いてAccessファイルからデータを拾おうとしています。
  • 抽出件数が2件以上なら正常に動作するのですが、1件、0件だと動作せず、フリーズしてしまいます。
  • 何が原因で、どう書き直せばよいのでしょうか?
回答を見る
  • ベストアンサー

Accessから値を抽出しようとするとフリーズする

Excelからマクロを用いてAccessファイルからデータを拾おうとしています。 方法は、Access内のテーブルを参照して検索対象の値1がフィールド内にあれば、その行の値2を抽出してくるといったものです。 検索対象の数は可変です。 そこでコードを書いてみたところ 抽出件数が2件以上なら正常に動作するのですが 1件、0件だと動作せず、フリーズしてしまいます。 何が原因で、どう書き直せばよいのでしょうか? 以下、コードです。 Private Sub OKButton_Click() '選択し、OKボタンを押した時 Dim p As Long Dim cnt As Long Range(Cells(45, 4), Cells(114, 6)).ClearContents 'D45~E115のセルを削除(二回目使用時にデータが残ってる為) cnt = ListView1.ListItems.Count '今まで選択してリストビューに追加された対象数を出し、変数へ。 For p = 1 To cnt Cells(44 + p, 4).Value = ListView1.ListItems.Item(p) Cells(44 + p, 5).Value = ListView1.ListItems.Item(p).SubItems(1) Cells(44 + p, 6).Value = ListView1.ListItems.Item(p).SubItems(2) Next p 'リストビューに追加された対象を、D45~E115に書き込み Dim Sql As String Dim i As Long Dim j As Long Dim k As Long Dim m As Long Dim n As Long Call DBconnect(True) Sql = _ "select Aコード,Bコード " & _ "from テーブル" '--- adoRsにSELECT文を入れ、絞り込む adoRs.Open Sql, adoCn, adOpenKeyset ' --- j:選択した対象の数を取得 k:Access内の選択した対象のデータ数を取得 n:列数 j = Worksheets("選択").Range("F45").End(xlDown).Row k = adoRs.Fields.Count n = 1 '--- Aコードが一致する行を選択シートの下部分へ書き込み。 ' --- 45 to jの45は、選択シートの選択した対象をセルに出力した場所が45行目の為。 ' --- cell(j+n,6)は、選択対象数を起点にBコード(値2)一つ毎に数を足していく、6はF列 Do Until adoRs.EOF For i = 45 To j If Worksheets("選択").Cells(i, 6).Value = adoRs!Aコード Then For m = 1 To k Worksheets("選択").Cells(j + n, 6) = adoRs.Fields!Bコード Next m n = n + 1 End If Next i adoRs.MoveNext Loop '後始末 adoRs.Close: Set adoRs = Nothing adoCn.Close: Set adoCn = Nothing

  • fwod
  • お礼率54% (47/86)

質問者が選んだベストアンサー

  • ベストアンサー
  • ShowMeHow
  • ベストアンサー率28% (1424/5027)
回答No.1

直接的な回答ではありませんが、デバッグの原則的な考え方を、、、 ブレークポイントを設定し、行ごとに実行させ値を確認して問題を突き止めてください。 今後のためにも、やり方を覚えておくと便利です。 http://kabu-macro.com/word/ha-ho/breakpoint.html http://www.atmarkit.co.jp/ait/articles/1402/20/news144.html

fwod
質問者

お礼

無事、解決致しました。 ありがとうございました

関連するQ&A

  • 可変の検索条件件数でAccessデータを抽出

    http://okwave.jp/qa/q8790348.html ここで質問をさせて頂いたのですが 私の質問方法が下手で、違う意味合いになっていましたので再度投稿させてください。 ■ やりたい事 ADOを用いて、Accessのテーブル内のフィールドに「指定の数値」がある場合 その行を全てExcelに抽出したい ■ 特徴 「指定の数値」は複数あり、なおかつ可変。  → VBAで作成したコンボボックス(Accessから読込)にて選択し、F45から下に好きな個数だけ追加 ■ つまづき点 「指定の数値」全てを検索対象に(OR検索)して SQLのSelect文で取得しようとしてもやり方が分からない ■ 現在のコード '宣言 Private adoCn As Object Private adoRs As Object Private strSQL As String Private Const DBpath = "\Access.mde" Sub DBconnect(flg As Boolean) 'DB呼出 Set adoCn = CreateObject("ADODB.Connection") If flg = True Then Set adoRs = CreateObject("ADODB.Recordset") adoCn.Open "Provider=Microsoft.jet.OLEDB.4.0;Data Source=" & DBpath & ";" End Sub Sub 対象() Dim tmpFldCnt As Variant Dim tmpRecCnt As Integer Dim buf() As Variant Call DBconnect(True) m = Worksheets("選択").Range("B47") Dim i As Long Dim j As Long i = 45 j = 44 + Worksheets("選択").Range("B47") 'B47:コンボボックスで選んだ個数分の数値 On Error GoTo err_hander adoCn.BeginTrans 'トランザクション処理開始 strSQL = _ "select * from TBL where コード = [選択$F" & i & ":F" & j & "]" 'F45より下に取得した値が入っていく adoRs.Open strSQL, adoCn, adOpenKeyset 'SQLを実行して、対象をadoRsへ tmpFldCnt = adoRs.Fields.Count tmpRecCnt = adoRs.RecordCount Range("M28:DG31").ClearContents ReDim buf(tmpFldCnt - 1, tmpRecCnt - 1) buf = adoRs.GetRows Range(Cells(28, 13), Cells(28 + tmpFldCnt - 1, 13 + tmpRecCnt - 1)) = buf adoCn.CommitTrans 'トランザクション終了 Call DBcut_off(True) 'DB切断呼び出し Exit Sub 色々と調べてみたものの、解決する気配がせず、どなたか知恵をお貸しください。

  • Accessの値をExcelに縦横入替出力したい

    以前 http://okwave.jp/qa/q8776430.html ここにて質問をさせて頂いたのですが、回答を頂いたことに感激し お恥ずかしい事に解決する前に先走って回答を締めきったものの どうしても解決できないので申し訳ないですが再度質問させて下さい。 質問:AccessからデータをExcelVBAでADOを使用して読み込み、 出力する前に縦横を入れ替えたいのですが その際に, adOpenstatic、adOpenKeyset などカーソルのタイプを変更しても recordcountが-1を返してしまうのですが、解決法を教えてください。 以下補足です。 -------------------------------------------------------------------- 現在、作業列を使って一旦AccessからデータをVBAでADOを使用して読み込み その後transpose関数で入れ替えているのですが 出力する前に縦横を入れ替えた状態にはできないのでしょうか? -------------------------------------------------------------------- という質問に対して、 Dim buf() As Variant Dim i As Long Dim j As Long   ・ 'ここにAccessファイルへのコネクションを設定   ・   ・ i = rs.Fields.Count j = rs.RecordCount ReDim mbuf(i - 1, j - 1) buf = rs.GetRows Range(Cells(1, 1), Cells(i, j)) = buf ------------------------------------------------------------- という回答を頂き パス(省略) Sub AcRecordCount() Dim tmpFldCnt As Variant Dim tmpRecCnt As Variant Dim buf() As Variant Call DBconnect(True) (省略) strSQLgenyu = _ "SELECT * " & _ "FROM TBL " & _ "WHERE コード = " & Range("J1") & _ "Or コード = " & Range("J2") 'J1、J2に一致したwhereフィールドの列を、fromテーブル名から全て(*)を出力 adoRs.Open strSQLgenyu, adoCn, adOpenKeyset 'SQLを実行して、対象をadoRsへ MsgBox (adoRs.RecordCount)  '-1が返ってくる tmpFldCnt = adoRs.Fields.Count tmpRecCnt = adoRs.RecordCount ReDim buf(tmpFldCnt - 1, tmpRecCnt - 1) 'インデックスが有効範囲にありませんとでる(恐らくrecordcountが原因) buf = adoRs.GetRows Range(Cells(131, 11), Cells(tmpFldCnt, tmpRecCnt)) = buf Range("EA11:JJ105").ClearContents 'セル内を削除 Range("EA11").CopyFromRecordset adoRs '出力 End Sub と、書いたのですが、-1が返ってきてしまいます。 原因は何なのでしょうか?

  • エクセルでのアクセスからのデータ抽出

    Web情報を参考にエクセルにて下記VBAコードを作りました。 Sub DB_Read() Dim adoCON As New ADODB.Connection Dim adoRS As New ADODB.Recordset Dim strSQL As String Dim odbdDB As Variant Dim wSheetName As Variant Dim i, j As Integer Dim GetName odbdDB = ActiveWorkbook.Path & "\test.accdb" adoCON.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;" _ & "Data Source=" & odbdDB & "" adoCON.Open j = 4 Do Until j = 18 GetName = Range("B4").Value & "_" & Cells(16, j).Value strSQL = "SELECT 規格値,Max,Min,結果1,結果2,結果3 FROM T_測定結果 WHERE [測定項目]='" & GetName & "'" adoRS.Open strSQL, adoCON, adOpenDynamic wSheetName = ActiveSheet.Name i = 20 adoRS.MoveLast Do Until adoRS.EOF Or i = 25 With Worksheets(wSheetName) .Cells(17, j).Value = adoRS!規格値 .Cells(18, j).Value = adoRS!Max .Cells(19, j).Value = adoRS!Min .Cells(i, j).Value = adoRS!結果1 .Cells(i + 10, j).Value = adoRS!結果2 .Cells(i + 20, j).Value = adoRS!結果3 End With i = i + 1 adoRS.MovePrevious Loop j = j + 1 Loop adoRS.Close Set adoRS = Nothing adoCON.Close Set adoCON = Nothing End Sub VBAを走らせると1巡は走るのですが、「Do Until j = 18」の2巡目に入ると、「wSheetName = ActiveSheet.Name」のところで「実行時エラー3705 アプリケーション定義またはオブジェクトの定義エラー」と出てしまいます。 エラーの原因が分からないので、アドバイスを頂きたいです。

  • vbaで、postgresqlアクセス問題

    vbaで、postgresqlアクセス問題:      データベースに、データは ***0000, でも、vbaで、取得したのは ****.四つの0が自動に、削除されました。      例: postgresqlに、 40000 ⇒ vbaで、取得した: 4   vbaソース:  Option Explicit Sub subPgGetData() Dim adoCn As New ADODB.Connection On Error GoTo ErrLogin: With adoCn .Provider = "PostgreSQL OLE DB Provider" .Properties("Data Source") = Range("B1").Value .Properties("Location") = Range("B2").Value .Properties("User ID") = Range("B3").Value .Properties("Password") = Range("B4").Value .Open End With On Error GoTo 0 Dim adoRs As New ADODB.Recordset On Error GoTo ErrSql: adoRs.Open Range("B6").Value, adoCn, adOpenForwardOnly, adLockReadOnly On Error GoTo 0 Workbooks.Add Cells.CopyFromRecordset adoRs Cells.Columns.AutoFit adoRs.Close: Set adoRs = Nothing adoCn.Close: Set adoCn = Nothing Exit Sub ErrLogin: MsgBox "" & vbCrLf & Err.Number & vbCrLf & Err.Description Set adoCn = Nothing Exit Sub ErrSql: MsgBox "" & vbCrLf & Err.Number & vbCrLf & Err.Description Set adoRs = Nothing adoCn.Close: Set adoCn = Nothing Exit Sub End Sub わかる方はご指示ください。 よろしくお願いします。

  • セルの値から任意の文字のみを抽出する

    こんにちは。 VBA勉強中です。 どうしても詰まってしまったので力を貸してください。・゜・(ノД`)・゜・。 Sheet1にはA列~J列にデータが入っています(行数は3行目~□行目・・・都度変わります) Sheet2には抽出したい文字の一覧(仮に禁止ワードとします)がB列5行目~○行目まで入ってます。 質問としてはSheet1のB列、D列、F列のそれぞれの値より禁止ワードを抽出する。 1つのセルに禁止ワードが0~最大5つ入っている時にK列から→方向に禁止ワードを並べて行くといった 感じです。 わかりにくくてすみませんが宜しくお願い致します。 以下自分で考えてみたコードです。。 これだと始めのB列のみ抽出に成功しましたがその他の列からは抽出できず・・・。゜(PД`q。)゜。 列Bで使用したコードをD列、F列にも使えると下に数値のみ変えて羅列しただけだからでしょうか;w; 本当に初心者ですみません。。 以下コードです。 Sub 禁止ワード抽出() Dim SR As Integer , LR As Integer, SR2 As Integer , LR2 As Integer , LR3 As Integer , LR4 As Integer Dim i As Long , j As Long , k As Long , m As Long Dim KINSHI As Variant SR = 3 SR2 =5 LR = Sheets("Sheet1").Range("B" Rows.Count).End(xlUp).Row LR2 = Sheets("Sheet1").Range("D" Rows.Count).End(xlUp).Row LR3 = Sheets("Sheet1").Range("F" Rows.Count).End(xlUp).Row LR4 = Sheets("Sheet2").Range("B" Rows.Count).End(xlUp).Row For j = SR2 To LR4 KINSHI = Sheets("Sheet2").Cells(j , 2).Value For i = SR To LR If Sheets(Sheet1).Cells(i , 2).Value Like ("*" & KINSHI & "*") Then If Cells(i , 10) = "" Then Cells(i , 10) = KINSHI Else   If Cells(i , 10 + 1) = "" Then Cells(i , 10 + 1) = KINSHI            Else   If Cells(i , 10 + 2) = "" Then Cells(i , 10 + 2) = KINSHI Else   If Cells(i , 10 + 3) = "" Then Cells(i , 10 + 3) = KINSHI Else   If Cells(i , 10 + 4) = "" Then Cells(i , 10 + 4) = KINSHI End If End If End If End If End If End If Next i , j 以下上記コードをD列、F列バージョンで並べています・・・・ End Sub 恐らくOffsetプロパティを使う方がいいと思いましたが中々うまくいかず 自分なりに色々考えてみてこんな残念な結果になってしまいましたが 皆様のお力添えどうぞ宜しくお願い致します。

  • Excel VBA : Accessのデータを検索

    Excel VBA を使って、Accessのデータを検索したい。 除外テーブルには「管理ID」レコードが在り、ユニークな番号を登録してあります。 やりたいことは、除外テーブルの管理IDに在るであろう、"E003"の有無を確認したいと思います。 作ってみたソースコードは、以下の通り。 Private Sub aSearch_Click() DB.TableOpen ("db_name.mdb") 'Accessのファイル DB.FindRecode ("E003")  ' 検索対象文字列 DB.TableClose End Sub ------------------------------ここから、標準モジュール Public adoCn As ADODB.Connection Public adoRs As ADODB.Recordset Public fSql As String Public fRow As Integer 'データ ソースへの接続と、レコードセットへの接続 Sub TableOpen(ByVal mdb_name As String) Set adoCn = New ADODB.Connection 'データ ソースへの接続 adoCn.Provider = "Microsoft.Jet.OLEDB.4.0" 'Accessへ接続プロバイダ名 adoCn.Open mdb_name '接続するmdbファイル名" fSql = "select 管理ID from 除外テーブル" Set adoRs = New ADODB.Recordset 'レコードセットへの接続 adoRs.Open fSql, adoCn, adOpenKeyset, adLockReadOnly 'クエリーの実行 ' adoRs.Open "除外テーブル", adoCn, adOpenKeyset, adLockReadOnly 'クエリーの実行 End Sub 'レコード(管理ID)の検索 Function FindRecode(ByVal findName As String) As String adoRs.Find adoRs.Fields("管理ID") & "=" & findName     '← ここでエラーとなる  If adoRs.RecordCount = 0 Then MsgBox "該当するレコードは存在しません" FindRecode = "" Exit Function Else Do     ' Doループは、要らないかも??? Debug.Print adoRs.Fields("管理ID") & "/" & adoRs.Fields("登録日") adoRs.MoveNext Loop Until adoRs.EOF End If FindRecode = adoRs.Fields("管理ID") End Function 'データ ソースへの接続と、レコードセットを切断する Sub TableClose() adoRs.Close 'クエリーを閉じる adoCn.Close 'データ接続を閉じる Set adoRs = Nothing Set adoCn = Nothing End Sub ------------- ここまで データのソースから、検索する方法が良く判っておらず、Open / find の使い方はこれで良いのでしょうか。 以上、よろしくお願いします。

  • 素数を求めるマクロを

    走らすと暴走したようになり、素数=151で止まります。 どこが悪いのでしょうか。正常に終わるようにしたいです。 ====================== Sub 素数を求める()   Dim i As Long   Dim j As Long   Dim m As Long   Dim p As Long   Dim flg As Boolean   i = 1   j = 1   p = 2   Do     flg = False     For m = 2 To Int(Sqr(p))       If p Mod m = 0 Then         flg = True         Exit For       End If     Next     If flg = False Then       Cells(i, j) = p       i = i + 1       If i > Rows.Count Then         i = 1         j = j + 1       End If     End If     p = p + 1   Loop End Sub ======================

  • INSERT INTOステートメント構文エラーにつ

    初めましてご教授よろしくお願いします。 ■環境 office365(ExcelとAccess) INSERT INTOステートメント構文エラーについての質問です。 著:今村ゆうこさんの『Excel&Access連携 実践ガイド』を読みながら現在作業を しています。 やりたいことはExcelのデータをaccessに書き込むことです。 エラー内容は「INSERT INTO ステートメントの構文エラーです。」と表示されます。 しかし、何度も見直して見ましたが、どこがエラーの原因かわかりません。 VBAは基本的部分が分かる程度で、現在勉強中です。 正直手詰まりといった感じで何を修正すれば良いかわからないというのが現状でこちらに質問させていただきました。 皆様の知恵を貸してください。どうかよろしくお願い致します。 ▼Excelデータ Product Name / Merchant SKU / ASIN / Condition / qty ○○(商品名) / テキスト / テキスト / テキスト / 個数 strSQL = _ "INSERT INTO テーブル(" & _ "Product Name, " & _ "Merchant SKU, " & _ "ASIN, " & _ "Condition, " & _ "qty) " & _ "VALUES(" & _ "'" & Cells(n, 1) & "', " & _ "'" & Cells(n, 2) & "', " & _ "'" & Cells(n, 3) & "', " & _ "'" & Cells(n, 4) & "', " & _ Cells(n, 5) & ");" ▼書籍に記載のあった例(添付CDのデータを丸々コピペしています) strSQL = _ "INSERT INTO 販売管理(" & _ "商品コード, " & _ "商品名, " & _ "売上日, " & _ "数量, " & _ "売価, " & _ "製造場所, " & _ "定価, " & _ "原価, " & _ "取引先, " & _ "営業所, " & _ "社員名) " & _ "VALUES(" & _ "'" & Cells(n, 1) & "', " & _ "'" & Cells(n, 2) & "', " & _ "#" & CDate(Cells(n, 3)) & "#, " & _ Cells(n, 4) & ", " & _ Cells(n, 5) & ", " & _ "'" & Cells(n, 6) & "', " & _ Cells(n, 7) & ", " & _ Cells(n, 8) & ", " & _ "'" & Cells(n, 9) & "', " & _ "'" & Cells(n, 10) & "', " & _ "'" & Cells(n, 11) & "');" ▼全体の文 Option Explicit '変数の宣言を強制する '---ACCESS接続用 Private adoCn As Object 'ADOコネクションオブジェクト Private adoRs As Object 'ADOレコードセットオブジェクト Private strSQL As String 'SQL文 Sub DBconnect(flg As Boolean) 'DB接続プロシージャ Dim DBpath As String DBpath = ThisWorkbook.Path Set adoCn = CreateObject("ADODB.Connection") 'ADOコネクションオブジェクトを作成 If flg = True Then Set adoRs = CreateObject("ADODB.Recordset") 'ADOレコードセットオブジェクトを作成 adoCn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & DBpath & "\SampleData.accdb;" 'Accessファイルを開く End Sub Sub DBcut_off(flg As Boolean) 'DB切断プロシージャ If flg = True Then adoRs.Close 'レコードセットのクローズ adoCn.Close 'コネクションのクローズ Set adoRs = Nothing 'オブジェクトの破棄 Set adoCn = Nothing End Sub Sub DBinsert_all() 'DB一括書込 Dim start_i As Long, end_i As Long, n As Long If MsgBox("一括書込を実行しようとしています。続けますか?", vbOKCancel) <> 1 Then 'メッセージ Exit Sub 'OK以外なら終了 End If If MsgBox( _ "Accessの「販売管理」テーブルのデータを一度削除し、" & vbCrLf & _ "現在このシートにある情報のみが書き込まれます。" & vbCrLf & _ vbCrLf & _ "実行してよろしいですか?", vbOKCancel + vbExclamation, "一括書込み") <> 1 Then 'メッセージ Exit Sub 'OK以外なら終了 End If start_i = 2 'スタート行 end_i = Range("A1").End(xlDown).Row '最終行を取得 Call DBconnect(False) 'DB接続 On Error GoTo Err_Handler 'エラーが起きたら"Err_Handler"へ adoCn.BeginTrans 'トランザクション開始 strSQL = "DELETE FROM 販売管理;" 'テーブル内データを全削除 adoCn.Execute strSQL '削除実行 For n = start_i To end_i 'データのある行を繰り返す strSQL = _ adoCn.Execute strSQL '書込実行 Next n adoCn.CommitTrans 'トランザクション終了(確定処理) Call DBcut_off(False) 'DB切断 MsgBox "正常に完了しました" Exit Sub

    • ベストアンサー
    • MySQL
  • 配列のフリーズを解消してください。

    Sub データ原本() Dim wsAll As Worksheet Set wsAll = Worksheets("All(5)") Dim lRow As Long, lCol As Long Dim i As Long, j As Long, cnt As Long With Worksheets("データ原本") '日付S行を日付に変更(「.」を「/」に置換) lRow = .Cells(Rows.Count, 1).End(xlUp).Row Dim MyArray As Variant MyArray = Range(.Cells(10, 1), .Cells(lRow, 1)) For i = 1 To lRow - 9 MyArray(i, 1) = Replace(MyArray(i, 1), ".", "/") Next Range(.Cells(10, 1), .Cells(lRow, 1)) = MyArray Erase MyArray '配列の初期化 '「天気」両サイドの &「内・外」両サイドの空白スペースを削除 lRow = .Cells(Rows.Count, 1).End(xlUp).Row MyArray = Range(.Cells(10, TNK), .Cells(lRow, TNK)) For i = 1 To lRow - 9 MyArray(i, 1) = Trim(MyArray(i, 1)) Next Range(.Cells(10, TNK), .Cells(lRow, TNK)) = MyArray Erase MyArray '配列の初期化 '数値0のデータ行の行削除 lRow = .Cells(Rows.Count, 1).End(xlUp).Row lCol = .Cells(9, Columns.Count).End(xlToLeft).Column Dim arr_A As Variant, arr_B As Variant arr_A = Range(.Cells(9, 1), .Cells(lRow, lCol)).Value ReDim arr_B(1 To lRow - 8, 1 To lCol) cnt = 0 For i = 1 To lRow - 8 If arr_A(i, 18) <> 0 Then cnt = cnt + 1 For j = 1 To lCol arr_B(cnt, j) = arr_A(i, j) Next j End If Next i .Range("A9").Resize(lRow, lCol).Value = arr_B End With End Sub  上記のコードを2回実行すると2回目には、 MyArray(i, 1) = Replace(MyArray(i, 1), ".", "/")のところで「型が一致しません。」とフリーズします。かと言って 「 '数値0のデータ行の行削除」コードを一括削除して、実行ボタンを何度押してもフリーズすることはありません。どこに不具合が生じているのかわからないのですが、どなたか名回答を宜しくお願いします。

  • セル内の値を消したら参照先セルを消す

    Excelのボタンクリックで下記コードにより上表のイニシャルがセル"B11:E13"に入力されるが下表の数字"B15"を消した場合、再度クリックしても入力されたイニシャルが消えないどんなコード入力をすれば良いのかどなたか解る方よろしくお願いします。 Sub 入力() Dim i As Long, j As Long On Error Resume Next For j = 2 To 5 For i = 1 To 3 Cells(i + 10, j) = WorksheetFunction.Index(Range("A1:A9"), WorksheetFunction.Match _ (i, Range(Cells(15, j), Cells(23, j)), False)) Next i Next j End Sub

専門家に質問してみよう