エクセルVBAでアクセスデータベースを抽出して読み込む方法

このQ&Aのポイント
  • エクセルVBAを使用してアクセスデータベースから特定の日付の情報を抽出する方法について説明します。
  • 日付を指定してアクセスデータベースから情報を抽出する際に、構文エラーが発生する場合の訂正方法について解説します。
  • エクセルのフォームにテキストボックスとコマンドボタンを配置し、日付を入力して検索を実行する方法について説明します。
回答を見る
  • ベストアンサー

エクセルVBAでアクセスデータベースを抽出して読み込む方法

エクセルVBAでアクセスデータベースを抽出して読み込む方法 アクセスで見積の提出情報のデータベースを作成しています。 このデータベースをエクセルのフォームで日付指定し抽出したいと考えております。 データベースの全てを読み込む事には成功したのですが、 いざフォームを作成し日付を入力。 実行したのですが、日付の構文エラーとなってしまいました。 抽出条件を表すSQLステートメントがおかしいのかもしれません。 どこを訂正したらよいのでしょうか? Private Sub CommandButton1_Click()  Dim rcs As ADODB.Recordset  Dim cnStr As String, sqlStr As String  Dim sday As Date  sday = TextBox1.Text '一覧のクリア、始点へ移動  Range("A5:N300").Select  Selection.ClearContents  Range("A5").Select 'データベースの保存場所  cnStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:\Accexl\見積予定.mdb" '検索条件  sqlStr = " SELECT * FROM 予定表 WHERE 作成日 = # sday #" 'データベースの読込、コピー、閉じる  Set rcs = New ADODB.Recordset  rcs.Open Source:=sqlStr, ActiveConnection:=cnStr, CursorType:=adOpenStatic  ActiveCell.CopyFromRecordset rcs  rcs.Close  Set rcs = Nothing   Range("C:C,E:E").Select   Selection.NumberFormatLocal = "h:mm;@"   Range("B:B,D:D").Select   Selection.NumberFormatLocal = "m/d;@"  Range("A3").Activate End Sub フォームの中にテキストボックス(日付を入力)、コマンドボタン(検索実行)を配置しています。 テキストボックスには日付表示するようにしています。 Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) Dim ret As Long   ret = 0   If KeyCode = vbKeyReturn Or KeyCode = vbKeyTab Then     With TextBox1       .Text = Replace(.Text, "/", "")       If IsNumeric(.Text) Then        If IsDate(Format(.Text, "0000""/""00""/""00")) Then         .Text = Format(.Text, "0000""/""00""/""00")         Else          ret = 1         End If       Else        ret = 1       End If      If ret = 1 Then       MsgBox "日付指定です"       KeyCode = 0     End If     End With    End If End Sub

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

  • ベストアンサー
  • piroin654
  • ベストアンサー率75% (692/917)
回答No.2

以下でどうですか。 sqlStr = " SELECT * FROM 予定表 WHERE 作成日 = #" & sday & "#"

ex1990
質問者

お礼

早速のご返事ありがとうございます。 早速試してみます。

その他の回答 (2)

  • utakataXEX
  • ベストアンサー率69% (711/1018)
回答No.3

#1です。 すいません。今試してみたら、#2さんのやり方でOKでした。 VBA上では #日付型# の記述はエラーになると勘違いしていました。

  • utakataXEX
  • ベストアンサー率69% (711/1018)
回答No.1

> 作成日 = # sday # Accessのクエリーの中ではこれでもOKですが、これは方言なので、他の言語から実行するなら、エラーになりますね。 とりあえず動くようにするなら Dim sday As String 'Date にしない  sday = TextBox1.Text (中略) 'フォームの日付の文字列をSQL側の関数で日付変換する sqlStr = " SELECT * FROM 予定表 WHERE 作成日 = cDate('" & strday & "')" (以下略) SQLインジェクションを回避する上では、上記の方法ではなくパラメータバインドを使用する方がベターですが、フォーム側で必ず暦日チェックがされているなら、まあOKでしょう。 (久しく書いていないのでADOでの記述を忘れましたw)

ex1990
質問者

お礼

早速のご返事ありがとうございます。 作成日 = # sday # は方言 なるほど勉強になります。 今仕事で使っているソフトがDOSなのです。 不便なので新しいソフトを探してはいるのですが、 なかなか難しいです。 そこで、何とか自分で作れないものだろうかと、いろいろなサイトを見て勉強中です。 まずは簡単なものから挑戦しています。 また解らない事があったら教えてください。 よろしくお願いします。

関連するQ&A

  • エクセルでアクセスデータベースを操作方法

    見積提出表をエクセルで作成しており、データの数が多く最近重くなってきました。 そこでこれらのデータをアクセスに写し、エクセル編集できないかと試行錯誤しております。 エクセルVBAでアクセスデータベースの抽出し、エクセルで編集また新規入力。 そしてまた、エクセルVBAでアクセスデータベースを編集また追加をしたいのですが・・・ 抽出まではうまくいきました。(下記VBAで) Private Sub CommandButton1_Click()  Dim rcs As ADODB.Recordset Dim cnStr As String, sqlStr As String    namae = TextBox1.Text '一覧のクリア、始点へ移動 Range("B3:S100").Select Selection.ClearContents Range("K3:K100") = "=ROUNDUP(J3/1.05,0)" Range("M3:M100") = "=K3-L3" Range("N3:N100") = "=IF(L3="""","""",ROUNDDOWN(M3/K3,4))" Range("B3").Select 'データベースの保存場所 cnStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:\DB案\見積提出状況.mdb" '検索条件 sqlStr = " SELECT * FROM 状況表 WHERE お客様名 LIKE '%" & namae & "%' " 'データベースの読込、コピー、閉じる Set rcs = New ADODB.Recordset rcs.Open Source:=sqlStr, ActiveConnection:=cnStr, CursorType:=adOpenStatic ActiveCell.CopyFromRecordset rcs rcs.Close Set rcs = Nothing Range("G3").Activate '検索フォームを閉じる Unload UserForm2 End Sub この後、エクセルで編集(データを一部変更)また、新規入力しアクセルのデータベースを変更しようと、 Private Sub CommandButton2_Click() Dim rcs As ADODB.Recordset Dim cnStr As String, sqlStr As String namae = TextBox1.Text Range("B3").Select 'データベースの保存場所 cnStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:\DB案\見積提出状況.mdb" '検索条件 sqlStr = " SELECT * FROM 状況表 WHERE お客様名 LIKE '%" & namae & "%' " 'データベースの読込、編集、登録、閉じる Set rcs = New ADODB.Recordset rcs.Open Source:=sqlStr, ActiveConnection:=cnStr, CursorType:=adOpenStatic, LockType:=adLockPessimistic  Do Until rcs.EOF rcs("チェック日付入力") = Range("C3") rcs("追加契約日") = Range("D3") rcs("状況") = Range("E3") rcs("日付") = Range("F3") rcs("お客様名") = Range("G3") rcs("工事名") = Range("H3") rcs("種類") = Range("I3") rcs("販売金額(税込)") = Range("J3") rcs("販売金額(税抜)") = Range("K3") rcs("実行金額(税抜)") = Range("L3") rcs("利益金額(税抜)") = Range("M3") rcs("利益率") = Range("N3") rcs("営業担当") = Range("O3") rcs("支店・営業所") = Range("P3") rcs("設計担当(見積担当)") = Range("Q3") rcs("部署") = Range("R3") rcs("備考") = Range("S3") rcs.Update rcs.MoveNext Loop rcs.Close Set rcs = Nothing '一覧のクリア、始点へ移動 Range("B3:S100").Select Selection.ClearContents Range("K3:K100") = "=ROUNDUP(J3/1.05,0)" Range("M3:M100") = "=K3-L3" Range("N3:N100") = "=IF(L3="""","""",ROUNDDOWN(M3/K3,4))" Range("B3").Select End Sub と考えていたのですが、これだと再度フォームを開き抽出条件を入力しなくてはならないですよね。 フォームを開かず、抽出条件入力もせず、アクセスデータベースを編集するには、どのようにしたら良いのでしょうか?

  • エクセルVBAを教えて下さい

    エクセルの表で -AB C D E F 1年月--1801 2------ 3------ 4------ (-)は空欄でセルE1=18、F1=1とします。 コントロールボックスをつかって Private Sub Command登録_Click() Dim d1 As Long Dim d2 As Long Dim ret As Variant Dim FindValue As String Dim TotalAddress As String If Range("E1").Value = "" Or Range("F1").Value = "" Then MsgBox "該当する場所にデータが入っていません。", vbCritical Exit Sub End If d1 = Range("A65536").End(xlUp).Offset(1).Row d2 = Range("B65536").End(xlUp).Offset(1).Row FindValue = """" & Range("E1").Value & Range("F1").Value & """" TotalAddress = Range("A1").Resize(d1).Address & "&" & Range("B1").Resize(d1).Address ret = Evaluate("MATCH(" & FindValue & "," & TotalAddress & ",0)") If IsError(ret) Then Cells(d1, 1) = Range("E1").Value Cells(d2, 2) = Range("F1").Value Else MsgBox "既に同じ組み合せがあります。", vbInformation End If End Sub というものを作ったのですが、E1=18、F1=1及びコマンドボタンを別シートに作成し、上記の表への登録をできるようにしたいのですが、なにかいい方法はありませんか?

  • エクセルVBAについて

    エクセルVBA初心者です。 左の表からある一定以上の売上を得た人を抽出し、右の表に表示したいのですが以下のプログラムだと上手くいきません。 どこがダメなのでしょうか? Private Sub cmdUriken_Click() Dim k As Integer Dim l As Integer Dim m As Integer k = 2 l = 2 m = 2 Do Until Cells(m, 32) = "" Range(Cells(m, 19), Cells(m, 34)).Select Selection.ClearContents m = m + 1 Loop Do Until Cells(k, 14) = "" If Cells(k, 14) >= txtUriken.Text Then Range(Cells(k, 1), Cells(k, 16)).Select Selection.Copy Range(Cells(l, 19), Cells(l, 34)).Select ActiveSheet.Paste l = l + 1 Application.CutCopyMode = False End If k = k + 1 Loop End Sub ちなみに If Cells(k, 14) = txtUriken.Text Then とするとちゃんと同等の売上が表示されるので >= の使い方が間違っていると思うのですが よろしくお願いします。

  • エクセルVBAで困っています。

     エクセルでSheet1でSheet2に各銀行の出納帳を作りそこから各項目ごとに別Sheetに振り分けたいと思っています。  ある方にエクセルVBAで作って頂いたのですが、最初作って頂いた時の項目は会費、会議費、事務費の3つでした。その項目を9つに増やしたいと思っています。又、全てのSheetで1行目には銀行名や項目名を入れたいので2行目から日付、内容・・・といったように入力したいです。そうした場合、どこをどう変更したらよいのか分かりません。自分がわかる範囲で(適当ですが)挑んでみたのですが、私自体VBAについて全く無知のため何が何だかサッパリです。どなたか教えて頂くことはできないでしょうか。ちなみに文字数に制限があったため改行やスペースなどは入れていません。見難いとは思いますがよろしくお願いします。どうか皆様のお知恵を貸して頂けると幸いです。 Option Explicit Sub Teller() '【考え方】Sheet1とSheet2を入力と考える。 'マクロを実行したときに、Sheet1,2を元に、項目別に振り分ける。 Const BankName1 As String = "○銀行" Const BankName2 As String = "(チェック)銀行" Const tempSheet As String = "一時シート" Dim classify(9) As String Dim title(5) As String Dim i As Long Dim j As Long Dim lastRow1 As Long Dim lastRow2 As Long Dim findUpper As Long Dim findLower As Long Dim keyword As String Dim ws As Worksheet Dim Bank1 As Worksheet Dim Bank2 As Worksheet Dim Temp As Worksheet Set Bank1 = Worksheets(BankName1) Set Bank2 = Worksheets(BankName2) '【振り分ける項目名】 classify(1) = "会費" classify(2) = "会議費" classify(3) = "事務費" classify(4) = "事業費" classify(5) = "研修費" classify(6) = "報償費" classify(7) = "慶弔費" classify(8) = "予備費" classify(9) = "積立金" '【1行目に記載する見出し】 title(1) = "日付" title(2) = "内容" title(3) = "収入" title(4) = "支出" title(5) = "残高" '画面更新を停止 Application.ScreenUpdating = False '最終行取得 Bank1.Select lastRow1 = Cells(Rows.Count, 1).End(xlUp).Row Bank2.Select lastRow2 = Cells(Rows.Count, 1).End(xlUp).Row 'シートを作る For i = 1 To 3 Call MakeNewSheet_As_ThisName(classify(i)) For j = 1 To 5 Cells(1, j) = title(j) Next j Next i Call MakeNewSheet_As_ThisName(tempSheet) Cells.ClearContents Set Temp = Worksheets(tempSheet) '一時シートに、銀行1のデータと銀行2のデータをコピーする。 Bank1.Select Bank1.Range(Cells(3, 1), Cells(lastRow1, 5)).Copy Temp.Select Temp.Range(Cells(1, 1), Cells(lastRow1 - 2, 5)).PasteSpecial Bank2.Select Range(Cells(3, 1), Cells(lastRow2, 5)).Copy Temp.Select Cells(lastRow1 - 1, 1).PasteSpecial 'ソートする。 '第一優先キー:B列。[項目]昇順。 '第二優先キー:A列。[日付]昇順。 Range("A1:E" & (lastRow1 + lastRow2 - 4)).Select With ActiveWorkbook.Worksheets(tempSheet).Sort .SortFields.Clear .SortFields.Add Key:=Range("B1:B" & (lastRow1 + lastRow2 - 4)), Order:=xlAscending '第一キー .SortFields.Add Key:=Range("A1:A" & (lastRow1 + lastRow2 - 4)), Order:=xlAscending '第二キー .SetRange Range("A1:E" & (lastRow1 + lastRow2 - 4)) .Apply End With For i = 1 To 3 keyword = classify(i) findUpper = 0 findLower = 0 '上から探す For j = 1 To lastRow1 + lastRow2 - 4 Step 1 If Cells(j, 2) = keyword Then findUpper = j Exit For End If Next j If findUpper > 0 Then '下から探す For j = lastRow1 + lastRow2 - 4 To 1 Step -1 If Cells(j, 2) = keyword Then findLower = j Exit For End If Next j 'コピー Range(Cells(findUpper, 1), Cells(findLower, 5)).Copy Sheets(keyword).Select Range("A2").Select ActiveSheet.Paste Range("B2:B" & 2 + (findLower - findUpper)).Delete Shift:=xlToLeft Sheets(tempSheet).Select End If Next i '一時シートの削除 Application.DisplayAlerts = False Temp.Delete Application.DisplayAlerts = True 'アクティブセルをA1にしておく For Each ws In Worksheets Sheets(ws.Name).Select 'シート選択 Application.CutCopyMode = False Range("A1").Select Next ws Bank1.Select '画面更新を行う Application.ScreenUpdating = True MsgBox "実行しました" End Sub Sub MakeNewSheet_As_ThisName(ByVal GivenName As String) 'シートの有無を確認し、無ければ作る Dim exist_flag As Boolean Dim ws As Worksheet exist_flag = False For Each ws In Worksheets If UCase(ws.Name) = UCase(GivenName) Then 'シートが存在する場合 exist_flag = True Exit For End If Next ws 'シートを作成 If GivenName = "" Then MsgBox "空白名のシートは作れません。" ElseIf exist_flag = False Then Sheets.Add After:=Sheets(Sheets.Count) ActiveSheet.Name = GivenName End If Sheets(GivenName).Select 'シート選択 End Sub

  • エクセルvbaで、同じ番号の請求書の金額をまとめる方法 2

    エクセルvbaで、同じ番号の請求書の金額をまとめる方法 2 すみません、前回質問して良い回答をいただいたのですが、こちらの手違いで 用件がひとつぬけていました。 A    B     I    K    L     M 11/5 B575    3000  7500 5000 13500 11/5 B575    4500      8500 11/6 B578    3000   3000 4000 40000 上記のように A日付 B請求書番号 I金額 K金額合計 が入力されています。 (IからKにとんでいるのは間違いではありません) M列にも同じようにL列の同じ請求書番号の金額の合計をセルを結合して中央揃えで表示したいのです。 以前のプログラムに加筆することで可能になるでしょうか。 下に貼り付けます。 Dim i As Long, j As Long Dim buf As Variant, ret As Double For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row buf = Val(Cells(i, 9).Value) '修正 If Cells(i, 2).Value <> Cells(i + 1, 2).Value Then If j = 0 Then j = i With Range(Cells(j, 11), Cells(i, 11)) .MergeCells = True .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With If buf + ret > 0 Then Cells(j, 11).Value = buf + ret End If Cells(j, 11).NumberFormat = "#,##0" ret = 0: j = 0 Else If j = 0 Then j = i ret = buf + ret End If Next ''合計欄 'With Cells(i, 4) ' .NumberFormat = "#,##0" ' .HorizontalAlignment = xlCenter ' .Formula = "= SUM(R1C:R[-1]C)" 'End With ご多忙の中申し訳ございませんがよろしくお願いします。

  • エクセルVBA-カウンター i と j の使い方

    2つの条件を同時に満たすと図形を別のワークシートにコピーし、600行程度あるワークシートなので For - Next を使ってその作業を繰り返す、というエクセルのマクロを以下のように書き込みました。ところがマクロを実行すると、一番最初の行だけ正確に実行され、次に条件を満たす行があっても図形がコピーされません。(ということはカウンター i, j の使い方が間違っているのです)どなたか私の素人コードを見て修正方法を教えてください。お願いします。 Sub finalize() Dim MyStr As String Dim i As Long Dim j As Long  For j = 2 To 1482 Step 40 For i = 3 To 188 Step 5 MyStr = Range("O" & i) If MyStr <> "" Then                    '条件1 If Range("L" & i).Value = "毎日" Then      '条件2   Sheets("図形_現読").Select ActiveSheet.Shapes.Range(Array("毎日")).Select Selection.Copy Sheets("印刷画面").Select Range("AG" & j).Select ActiveSheet.Paste Else If Range("L" & i).Value = "朝刊" Then Sheets("図形_現読").Select ActiveSheet.Shapes.Range(Array("朝刊")).Select Selection.Copy Sheets("印刷画面").Select Range("AG" & j).Select ActiveSheet.Paste End If End If End If Next i Next j End Sub

  • EXCEL VBA

    EXCEL VBAで空白行が現れたら「小計」の文字を入力したいと思い以下のように記述しましたが、うまくいきません。どこがおかしいのか教えてください。 宜しくお願いします。 Sub write小計() Dim i As Integer Dim rowcnt As Integer rowcnt = Cells(1, 1).CurrentRegion.Rows.Count Range("B1").Select For i = 1 To rowcnt If Cells(i, 2).Value = "" Then Value = "小 計" ActiveCell.Offset(1).Select Next i End Sub

  • Excel VBAフォーム 登録ボタンの作成方法

    いつもお世話になっています。 初めて、Excelのフォームで入力画面を作りました。 複数の項目があって、それを最後に[登録]ボタンをクリックで 表に入れたいのですが、一度にまとめて実行する方法が分かりません。 アドバイスよろしくお願いいたします。 Private Sub cmd_1() Dim i As String If man.Value = True Then ActiveCell = man.Caption End If If woman.Value = True Then ActiveCell = woman.Caption End If ActiveCell.Offset(0, 1).Select End Sub Private Sub cmd_2() Dim i As String If man.Value = True Then ActiveCell = Yes.Caption End If If woman.Value = True Then ActiveCell = No.Caption End If ActiveCell.Offset(0, 1).Select End Sub Private Sub cmd_downlist() Dim ListNo As Long ListNo = group.ListIndex ActiveCell.Value = group.List(ListNo, i) ActiveCell.Offset(0, 1).Select End Sub Private Sub cmd_comment() ActiveCell = comment.Text ActiveCell.Offset(1, -3).Select End Sub

  • エクセル VBA タブストップに対する質問2

    下記の「エクセル VBA タブストップに対する質問」に書き込みした者ですが、一難去ってまた一難です。又、暗雲が漂ってきました。 条件は下記といっしょで テキストボックスが1~5まであり、テキストボックス2~4まではデータが入っています。 全てのTabStopはTrue、TabIndexは順に1~5が入っています。 テキストボックス1に何もデータを入れないで、Enterが押された場合、 テキストボックス1をアクティブにしたいのですが、下記で質問した回答で動かしても、きちんと動いてくれません。 どうかご指導よろしくお願いいたします。 Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Then 'ENTER If TextBox1.Value = "" Then TextBox1.SetFocus End If End If End Sub このコードでテキストボックス1に何も入れずにEnterを押すとテキストボックス2がアクティブになってしまいます。

  • エクセル VBA シートの選択 

    windows XP でエクセル2000を使っています。 Sub aaa() Sheets("Sheet1").Select Dim a As String a = Cells(2, 4) Sheets(a).Select Range("A1").Select End Sub というマクロだと セルに入っている値のシート名を探してくれます。 ですが Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) If Intersect(Target, Range("B11:b683")) Is Nothing Then Exit Sub Worksheets("Sheet1").Range("C2").Value = Target.Value Dim b As String b = Range("C2).value (←ここをcellsにしてもダメ) Sheets(b).Select Range("A1").Select End Sub これだとsheets(b)を選びません。Sheets(b).Selectのところが黄色くなります。 何処が間違えているのでしょうか。 全くの素人ですが、仕事で必要に迫られています。 わかりやすく回答・解説くれると助かります。