Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


5987 / 13644 ツリー ←次へ | 前へ→

【46311】アクセスのクエリを実行したい phoo 07/1/30(火) 13:00 質問[未読]
【46313】Re:アクセスのクエリを実行したい neptune 07/1/30(火) 13:29 発言[未読]
【46362】Re:アクセスのクエリを実行したい 1 ichinose 07/1/31(水) 21:54 発言[未読]
【46363】Re:アクセスのクエリを実行したい 2 ichinose 07/1/31(水) 21:54 発言[未読]
【47697】Re:アクセスのクエリを実行したい 2 phoo 07/3/19(月) 17:00 質問[未読]
【47709】Re:アクセスのクエリを実行したい 2 ichinose 07/3/20(火) 7:56 発言[未読]
【47731】Re:アクセスのクエリを実行したい 2 ichinose 07/3/21(水) 8:09 発言[未読]
【47837】Re:アクセスのクエリを実行したい 2 phoo 07/3/23(金) 18:35 お礼[未読]
【46318】Re:アクセスのクエリを実行したい Kein 07/1/30(火) 14:39 回答[未読]
【46319】Re:アクセスのクエリを実行したい Kein 07/1/30(火) 14:41 発言[未読]
【46321】Re:アクセスのクエリを実行したい phoo 07/1/30(火) 15:43 お礼[未読]

【46311】アクセスのクエリを実行したい
質問  phoo  - 07/1/30(火) 13:00 -

引用なし
パスワード
   VBA初心者です。
今、販売数や在庫数を管理するToolを作っています。
データはアクセスに蓄積し、エクセルで必要な期間のデータを抽出したいと思っています。
こちらの過去ログを参考にさせていただいて下記のようなコードを作成しました。
UserForm2のTextBox1に開始日、TextBox2に終了日を入力しそれをクエリのパラメーターへ渡しデータを抽出しようとしていますが、TextBox1とTextBox2にどのような日付を入れてもテーブルにあるすべてのデータが抽出されてしまいます。
初心者のためコードも見よう見真似です。
どなたかご教授いただけませんでしょうか?よろしくお願いします。


<クエリ>
販売日 日付/時刻型  Between [Date1] and [Date2]
店舗  テキスト型
数量  データ型


Private Sub 販売数抽出()

Dim Cn As ADODB.Connection
Dim Rs As ADODB.Recordset
Dim Cmd As ADODB.Command

Set Cn = New ADODB.Connection
Cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.Path & "\在庫管理.mdb"
Set Rs = New ADODB.Recordset
Set Cmd = New ADODB.Command
Cmd.ActiveConnection = Cn

Cmd.CommandText = "販売数"
Set Rs = Cmd.Execute(Parameters:=Array(UserForm2.TextBox1.Text, UserForm2.TextBox2.Text)

ActiveSheet.Range("a2").CopyFromRecordset Rs
Set wcmd = Nothing
Rs.Close: Set Rs = Nothing
Cn.Close: Set Cn = Nothing

End Sub

【46313】Re:アクセスのクエリを実行したい
発言  neptune  - 07/1/30(火) 13:29 -

引用なし
パスワード
   ▼phoo さん:
こんにちは

Parameters:= は使ったことないのでわかりませんが、
UserForm2.TextBox1.Textは文字列型ですから、パラメータが日付型だったら
どうなるんですかね?

CreateParameterでパラメータの定義をきっちりやってはどうですか?

【46318】Re:アクセスのクエリを実行したい
回答  Kein  - 07/1/30(火) 14:39 -

引用なし
パスワード
   私はDAOしか使わないので、DAOのコード例を提示します。
ユーザーフォームに配置したボタンを押して、Sheet1 に指定の日付期間の
データを引っ張るコードです。
(参照設定で Microsoft DAO 3.6 Object Library にチェック)

Private Sub CommandButton1_Click()
  Dim MyDB As DAO.Database, MyRS As DAO.Recordset
  Dim StDy As String, EDy As String, MySQL As String

  If Not IsDate(TextBox1.Value) Or _
  Not IsDate(TextBox2.Value) Then
   MsgBox "テキストボックスの値は日付として認識できません", 48
   Exit Sub
  End If     
  StDy = Format(CDate(TextBox1.Value), "yyyy/mm/dd")
  EDy = Format(CDate(TextBox2.Value), "yyyy/mm/dd")
  MySQL = "SELECT 店舗, 数量 FROM 販売数 WHERE 販売日 >= #" & _
  StDy & "# AND 販売日 <= #" & EDy & "#;"
  Set MyDB = DBEngine.Workspaces(0) _
  .OpenDatabase(ThisWorkbook.Path & "\在庫管理.mdb")
  Set MyRS = MyDB.OpenRecordset(MySQL)
  Sheets("Sheet1").Range("A2").CopyFromRecordset MyRS
  Close MyRS: Close MyDB
  Set MyRS = Nothing: Set MyDB = Nothing
End Sub

【46319】Re:アクセスのクエリを実行したい
発言  Kein  - 07/1/30(火) 14:41 -

引用なし
パスワード
   訂正。
>Close MyRS: Close MyDB


MyRS.Close: MyDB.Close

ども。

【46321】Re:アクセスのクエリを実行したい
お礼  phoo  - 07/1/30(火) 15:43 -

引用なし
パスワード
   neptuneさん
Keinさん

うまくいきました。
ありがとうございました。

また何かにつまずいた際にはよろしくお願いします。

【46362】Re:アクセスのクエリを実行したい 1
発言  ichinose  - 07/1/31(水) 21:54 -

引用なし
パスワード
   こんばんは。
既に解決しているようですが、
Keinさんコードで解決されたのでしょうね!!


>
>Parameters:= は使ったことないのでわかりませんが、
>UserForm2.TextBox1.Textは文字列型ですから、パラメータが日付型だったら
>どうなるんですかね?
でも、滅多にお目にかかれないせっかくのパラメータクエリの問題だったので
これが朝から気になっていました。
(朝の忙しい時には、検証できませんでしたが・・・)

パラメータクエリの場合は 'も#も%も要らないと思いましたが
私も試したことはありませんでした。(文字列では要らなかった)

で試しました。結果は、要りません。

でよかったら、皆さんも再現してみてください。

まず、新規ブック(Sheet1というシートは必ず存在する)
にユーザーフォームを作成してください。

ユーザーフォームのコントロール構成は以下のとおりです。

Userform1
  コマンドボタン----Commandbutton1 サンプルDB作成用
  テキストボックス---TextBox1    日付範囲指定 開始日
  テキストボックス---TextBox2    日付範囲指定 終了日
  コマンドボタン----Commandbutton2 パラメータクエリ実行用
  

まず、標準モジュールに

'=================================================================
Option Explicit
Sub main()
  Sheets("sheet1").Select
  UserForm1.Show
End Sub


別の標準モジュールにDBを操作するプロシジャー群
'================================================================
Option Explicit
Private cat As Object
'================================================================
Function create_cat(flnm As String) As Long
  On Error Resume Next
  Set cat = CreateObject("ADOX.Catalog")
  cat.Create "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=" & flnm
  create_cat = Err.Number
  On Error GoTo 0
End Function
'================================================================
Function open_cat(flnm As String) As Long
  On Error Resume Next
  Set cat = CreateObject("ADOX.Catalog")
  cat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & flnm
  open_cat = Err.Number
  On Error GoTo 0
End Function
'================================================================
Function get_cn() As Object
  Set get_cn = cat.ActiveConnection
End Function
'================================================================
Function cr_cmd(text As String, nm As String) As Long
  On Error Resume Next
  cr_cmd = 0
  cat.Views.Delete nm
  Err.Clear
  Dim cmd As Object
  Set cmd = CreateObject("ADODB.Command")
  cmd.CommandText = text
  cat.Views.Append nm, cmd
  cr_cmd = Err.Number
  On Error GoTo 0
End Function
'================================================================
Function exe_cmd(o_obj As Object, nm, Optional myarray As Variant = "") As Long
'パラメータクエリ実行ルーチン
  On Error Resume Next
  Dim cmd As Object
  Set cmd = CreateObject("ADODB.Command")
  With cmd
    .CommandText = nm
    .ActiveConnection = get_cn
    If TypeName(myarray) = "String" Then
     Set o_obj = cmd.Execute
    Else
     Set o_obj = cmd.Execute(Parameters:=myarray)
     End If
    End With
  exe_cmd = Err.Number
  On Error GoTo 0
End Function
'================================================================
Function Exec(sql_str) As Long
  On Error Resume Next
  Exec = 0
  cat.ActiveConnection.Execute sql_str
  If Err.Number <> 0 Then
    Exec = Err.Number
    End If
  On Error GoTo 0
End Function
'================================================================
Sub delete_fl(flnm)
  On Error Resume Next
  Kill flnm
  On Error GoTo 0
End Sub
'================================================================
Function append_autonumber_col(tblnm, colnm) As Long
  Dim col As ADOX.Column
  Set col = New ADOX.Column
  With col
   .Name = colnm
   .Type = adInteger
   Set .ParentCatalog = cat
   .properties("AutoIncrement") = True
   End With
  cat.Tables(tblnm).Columns.Append col
  Set col = Nothing
  append_autonumber_col = 0
End Function
'================================================================
Function create_tbl(tblnm As String, nmarray, tparray, attarray, blkarray) As Long
'tblnmというテーブルを作成し、最初の列に主キーを設定する
'Input:tblnm----テーブル名
'   nmarray----列の名前の配列
'   tparray----列のタイプの配列
'   attarray---列のオートナンバーか否かの配列 Trueオートナンバー、falseオートナンバーでない
'   blkarray---空白を許可する --true許可 false許可しない
  On Error GoTo err_create_tbl
  Dim RS As Object
  Dim tbl As Object
  Dim col As Object
  Dim kky As Object
  Dim idx As Long
  Dim jdx As Long
  create_tbl = 0
  Set tbl = CreateObject("ADOX.Table")
  tbl.Name = tblnm
  jdx = 0
  For idx = LBound(nmarray) To UBound(nmarray)
    Set col = CreateObject("ADOX.Column")
    With col
     
     .Name = nmarray(idx)
     .Type = tparray(idx)
     Set .ParentCatalog = cat
     .properties("AutoIncrement") = attarray(idx)
     .properties("Jet OLEDB:Allow Zero Length") = blkarray(idx)
     .DefinedSize = 100
     End With
    tbl.Columns.Append col
    Set col = Nothing
    Next idx
  cat.Tables.Append tbl
  Set kky = CreateObject("ADOX.Key")
  cat.Tables(tblnm).Keys.Append nmarray(LBound(nmarray)), 1, nmarray(LBound(nmarray))
  Set tbl = Nothing
  Set col = Nothing
  On Error GoTo 0
ret_create_tbl:
  Exit Function
err_create_tbl:
  MsgBox Error(Err.Number)
  create_tbl = Err.Number
  Resume ret_create_tbl
End Function
'================================================================
Function get_tblnm()
'テーブル名の列挙
  Dim mytbl()
  Dim tbl As Object
  idx = 1
  For Each tbl In cat.Tables
   If UCase(tbl.Type) = UCase("table") Then
     ReDim Preserve mytbl(1 To idx)
     mytbl(idx) = tbl.Name
     idx = idx + 1
     End If
   Next
  If idx > 1 Then
   get_tblnm = mytbl()
  Else
   get_tblnm = False
   End If
End Function
'================================================================
Sub close_cat()
  On Error Resume Next
  get_cn.Close
  Set cat = Nothing
  On Error GoTo 0
End Sub

尚、このプロシジャー群は今回の事象には使っていないものも含まれています。


Userform1のモジュールに
'===================================================================
Option Explicit
Const flnm = "sample.mdb"
Const qry_samp = "qry_samp"
Private Sub CommandButton1_Click()
  Dim dbpath As String
  Dim retcode As Long
  Dim nm As Variant
  Dim tp As Variant
  Dim att As Variant
  Dim blk As Variant
  Dim sqlstr As String
  dbpath = ThisWorkbook.Path & "\" & flnm
  Call delete_fl(dbpath)
  retcode = create_cat(dbpath)
  If retcode = 0 Then
    nm = Array("dbid", "dbdate", "dbstr")
      tp = Array(3, 7, 202)
      att = Array(True, False, False)
      blk = Array(False, False, True)
      retcode = create_tbl("tblsamp", nm, tp, att, blk)
      If retcode = 0 Then
        With Worksheets("sheet1")
         .Range("a:c").ClearContents
         .Range("a1:c1").Value = Array("dbid", "dbdate", "dbstr")
         With .Range("a2:c21")
           .Formula = Array("=row()-1", "=""2007/1/1""+row()-1", "=REPT(CHAR(63+row()),3)")
           .Value = .Value
           .Columns(2).NumberFormatLocal = "yyyy/m/d"
           End With
         End With
        sqlstr = "insert into [tblsamp] SELECT dbid, dbdate, dbstr FROM [Excel 8.0;Database=" _
             & ThisWorkbook.FullName & "]" & ".[sheet1$a1:c21];"
        If Exec(sqlstr) = 0 Then
         If cr_cmd("SELECT * FROM tblsamp where dbdate between [date1:] and [date2:];", qry_samp) = 0 Then
'パラメータクエリの作成
           MsgBox "サンプル作成成功"
         Else
           MsgBox "クエリー作成失敗"
           End If
        Else
         MsgBox "サンプル作成失敗"
         End If
      Else
        MsgBox Error$(retcode)
        End If
   Else
    MsgBox Error(retcode)
    End If
   Call close_cat
End Sub
'=========================================================================
Private Sub CommandButton2_Click()
  Dim dbpath As String
  Dim myRS As Object
  dbpath = ThisWorkbook.Path & "\" & flnm
  Set myRS = CreateObject("adodb.recordset")
  If open_cat(dbpath) = 0 Then
    If exe_cmd(myRS, qry_samp, Array(TextBox1.text, TextBox2.text)) = 0 Then
'パラメータクエリの実行
     With Worksheets("sheet1")
       .Range("f:h").ClearContents
       .Range("f1:h1").Value = Array("dbid", "dbdate", "dbstr")
       .Range("f2").CopyFromRecordset myRS
       .Range("g:g").NumberFormatLocal = "yyyy/m/d"
       End With
     myRS.Close
    Else
     MsgBox "error"
     End If
    Call close_cat
  Else
    MsgBox "接続失敗"
    End If
  Set myRS = Nothing
End Sub

以上です。

【46363】Re:アクセスのクエリを実行したい 2
発言  ichinose  - 07/1/31(水) 21:54 -

引用なし
パスワード
   一度、上記のブックを適当な名前で保存した後にmainを実行してください。

・Userform1が表示されます。

・Commandbutton1をクリックしてください。

・このブックと同じフォルダに「sample.mdb」が作成されます。

・このmdbファイルには、tblsampというテーブルが作成されるはずです。

・tblsampのフィールド構成は、
   dbid ----- 整数
   dbdate----- 日付
   dbstr------ 文字型

の3つのフィールドから構成されています。
サンプルデータは、中を確認していただければわかりますが、
このブックのSheet1のA列から、C列の内容をエクスポートしています。
(Commandbutton1の実行でA列からC列には、テーブルにエクスポートした
 内容が表示されます)

・さらに「qry_samp」という名前のパラメータクエリを作成しています。
(日付の範囲を指定し、その範囲データをtblsampから、検索します)


・実際にこのパラメータクエリを活用してみます。

・Textbox1及び、Textbox2に抽出するデータの日付範囲を指定して下さい。
 必ず、両方に日付を指定すること。
(yyyy/mm/dd形式で指定して下さい。例 2007/1/5)

・指定したら、Commandbutton2をクリックしてください。

・抽出内容が Sheet1のF列からH列に表示されます。

・日付を変えて試してみてください。


結果、パラメータクエリが正しく作成されていれば、phooさんの提示された
コードで正しく抽出されるはずですけどね・・・。

【47697】Re:アクセスのクエリを実行したい 2
質問  phoo  - 07/3/19(月) 17:00 -

引用なし
パスワード
   ichinoseさん、

はじめまして。
まずはお礼が遅くなりましたことお詫びいたします。
申し訳ございませんでした。
とても丁寧でためになりました。

今回は前回の質問に加えて再度教えていただきたいのですが…


ユーザーフォームにはTextBox1〜6、CommandButton1、
アクセスのテーブルに以下のようなフィールドが6つあります。
  実施日  (日付)
  会場   (テキスト)
  商品   (テキスト)
  対象   (テキスト)
  センター (テキスト)
  結果   (テキスト)

クエリを実行させて指定期間のレコードを抽出する方法は前回でわかったのですが、
更にその他の項目についても同時に抽出条件を設定する方法はありますか?
 例えば、実施日:2007/01/01〜2007/03/10
      会場:大阪(を含む語)
      センター:滋賀(を含む語)
     (TextBoxになにも入力がない場合は、すべてを抽出)

よろしくお願いします。

【47709】Re:アクセスのクエリを実行したい 2
発言  ichinose  - 07/3/20(火) 7:56 -

引用なし
パスワード
   おはようございます。


>はじめまして。
>まずはお礼が遅くなりましたことお詫びいたします。
>申し訳ございませんでした。
>とても丁寧でためになりました。
>
>今回は前回の質問に加えて再度教えていただきたいのですが…
>
>
>ユーザーフォームにはTextBox1〜6、CommandButton1、
>アクセスのテーブルに以下のようなフィールドが6つあります。
>  実施日  (日付)
>  会場   (テキスト)
>  商品   (テキスト)
>  対象   (テキスト)
>  センター (テキスト)
>  結果   (テキスト)
>
>クエリを実行させて指定期間のレコードを抽出する方法は前回でわかったのですが、
>更にその他の項目についても同時に抽出条件を設定する方法はありますか?
> 例えば、実施日:2007/01/01〜2007/03/10
>      会場:大阪(を含む語)
>      センター:滋賀(を含む語)
>     (TextBoxになにも入力がない場合は、すべてを抽出)

これは、Keinさんのコード例に倣ったほうが良いと思いますよ!!

何を倣うのか というと、

コード内でSQL文を作成するという箇所です。
Keinさんコードは、今回の事例より、SQLの構築は簡単(条件が少ないので)ですが、
コード内でSQL文を組み立てています。

条件が多くなった今回(Textbox1〜Textbox6に入力された内容が抽出条件でしょ?)は、入力された抽出条件(Textbox1〜Textbox6に入力された内容)を基に
SQLを構築します。

具体的には、Keinさんの

>"SELECT 店舗, 数量 FROM 販売数 WHERE 販売日 >= #" & _
  StDy & "# AND 販売日 <= #" & EDy & "# "

このSqlに and 会場 like 'xxxx'

というような条件をTextboxのデータを基に追加していくことだと思います。

まずは、Sqlを抽出条件を基に作成することを考えてみてはいかがですか?

【47731】Re:アクセスのクエリを実行したい 2
発言  ichinose  - 07/3/21(水) 8:09 -

引用なし
パスワード
   おはようございます。

前回、私が投稿した

www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=46362;id=excel

これに文字列フィルタを追加した別解です
(私は、普段は、sql派?なんですが、レコードセットのFilterを使ってみました。
これも簡単で良いですねえ!!)


userform1更にテキストボックス(Textbox3)を追加してください。

sample.mdbのtblsampというテーブルの文字型フィールドである

dbstrの抽出条件入力用です。


Userform1のCommandbutton2のクリックイベントプロシジャーだけ
以下のように変更します。
(他のコードは前回と同じですよ!!要らないわけではありませんから・・)


'===============================================================
Private Sub CommandButton2_Click()
  Dim dbpath As String
  Dim myRS As Object
  dbpath = ThisWorkbook.Path & "\" & flnm
  Set myRS = CreateObject("adodb.recordset")
  If open_cat(dbpath) = 0 Then
    If exe_cmd(myRS, qry_samp, Array(TextBox1.text, TextBox2.text)) = 0 Then
'パラメータクエリの実行
     With Worksheets("sheet1")
       .Range("f:h").ClearContents
       .Range("f1:h1").Value = Array("dbid", "dbdate", "dbstr")
'***********************************************************************
'追加コード
       If TextBox3.text <> "" Then
        myRS.Filter = "dbstr like '*" & TextBox3.text & "*'"
        End If
'***********************************************************************
       .Range("f2").CopyFromRecordset myRS
       .Range("g:g").NumberFormatLocal = "yyyy/m/d"
       End With
     myRS.Close
    Else
     MsgBox "error"
     End If
    Call close_cat
  Else
    MsgBox "接続失敗"
    End If
  Set myRS = Nothing
End Sub


これで前回と同様の操作(コマンドボタン1をクリック)でデータベースサンプル
を作成した後、

Textbox1とTextbox2に日付範囲をYYYY/MM/DD形式で入力

Textbox3にはフィールドdbstr抽出条件を入力してください。


Textbox1 2007/1/2
textbox2 2007/1/10
textbox3 B

と入力し、コマンドボタン2をクリックしてください。

抽出結果がF列から、

dbid  dbdate   dbstr
2   2007/1/3   BBB

のように表示されます。


上記のサンプルで試された後、実際のDBでも同じ要領で試してみては?

【47837】Re:アクセスのクエリを実行したい 2
お礼  phoo  - 07/3/23(金) 18:35 -

引用なし
パスワード
   ichinose さん

いつもご丁寧な対応をしていただきありがとうございます。
とても助かっております。

今回はおっしゃるとおりKeinさんの例に倣ってやるとうまくいきました。
本当にありがとうございました。

またよろしくお願いします。

5987 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free