演習35 と同様、ADO を使用するために、最初に Excel VBA の VBエディタ に
おいて、次の設定を行う。 ここのコードによるファイル kakcho14.xls では、
どの PC 上でも動作するように、ADO のバージョン 2.1 を設定してある。

各モジュールに、以下のプロシージャを記述し実行すると、Excel のフォーム
モジュールから Access のテーブル上のデータを検索し、それを編集加工して
Excel のシート上に転記することができる。

　　　　VBE - ツール - 参照設定 -
　　　　　(レ)Microsoft ActiveX Data Objects 2.1 Library

Access の既存のデータベースファイル名を 'acctest4.mdb' とし、その中に
次の二つのテーブルの '氏名テーブル, 住所テーブル' を事前に作成してある
ものとしている。 二つのファイル 'kakcho14.xls' と 'acctest4.mdb' は、
同じフォルダに置くこと。

　　


'-------- [ThisWorkbook] ---------
Private Sub Workbook_Open()
  UserForm1.Show False
End Sub

'---------- [UserForm1] ----------
Dim Dbs As New ADODB.Connection  'ADOコネクション
Dim Rcsa As New ADODB.Recordset  'ADOレコードセット1
Dim Rcsb As New ADODB.Recordset  'ADOレコードセット2
Dim RcQ As New ADODB.Recordset   'SQLレコードセット
Dim Rcd As Integer               'エクセルのレコード表示行
Dim mydbF As String              'アクセス ファイル

Private Sub UserForm_Initialize()
  '例として acctest4.mdb の テーブル から読み込む
  mydbF = "acctest4.mdb"   'アクセス ファイル
  
  'アクセスデータベース接続設定
  Dbs.ConnectionString = _
    "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=" & ThisWorkbook.Path & _
    "\" & mydbF & ";"

  'アクセスデータベース接続
  Dbs.Open
  
  '住所コンボボックスを SQL文で設定
  '(行末の半角スペースに注意)
  Rcsb.Open _
    "Select 住所コード,住所 " & _
    "From 住所テーブル " & _
    "Order by 住所コード asc;", Dbs

  Do Until Rcsb.EOF
    ComboBox2.AddItem _
      Rcsb!住所コード & " " & _
      Rcsb!住所
    Rcsb.MoveNext
  Loop
  ComboBox2.ListIndex = -1   '初期設定
    
  '所属コンボボックスを SQL文で設定
  Rcsa.Open _
    "Select 所属 " & _
    "From 氏名テーブル;", Dbs

  Do Until Rcsa.EOF
    ComboBox3.AddItem _
      Rcsa!所属
    Rcsa.MoveNext
  Loop
  ComboBox3.ListIndex = -1   '初期設定
    
  '合計コンボボックスの以上未満の設定
  With ComboBox4
    .AddItem "以上"
    .AddItem "未満"
    .ListIndex = -1          '初期設定
  End With
  
  '表示順序コンボボックスの設定
  With ComboBox5
    .AddItem "番号の昇順"
    .AddItem "番号の降順"
    .AddItem "住所の昇順"
    .AddItem "住所の降順"
    .AddItem "合計の昇順"
    .AddItem "合計の降順"
    .ListIndex = 0          '初期設定
  End With
  
  '検索条件を すべて に初期設定
  OptionButton1.Value = True
  CheckBox1.Enabled = False
  CheckBox2.Enabled = False
  CheckBox3.Enabled = False
  CheckBox4.Enabled = False
End Sub
'---------------------------------

Private Sub UserForm_QueryClose _
  (Cancel As Integer, CloseMode As Integer)
  '終了
  Rcsa.Close
  Rcsb.Close
  Dbs.Close
  Set Rcsa = Nothing
  Set Rcsb = Nothing
  Set Dbs = Nothing
End Sub
'---------------------------------

Private Sub OptionButton1_Click()
  'すべてを選択なら チェックボックス無効
  If OptionButton1 = True Then
    CheckBox1.Enabled = False
    CheckBox2.Enabled = False
    CheckBox3.Enabled = False
    CheckBox4.Enabled = False
  End If
End Sub
'---------------------------------

Private Sub OptionButton2_Click()
  '条件付きを選択なら チェックボックス有効
  If OptionButton2 = True Then
    CheckBox1.Enabled = True
    CheckBox2.Enabled = True
    CheckBox3.Enabled = True
    CheckBox4.Enabled = True
  End If
End Sub
'---------------------------------

Private Sub CommandButton1_Click()
  '指定した条件を SQL文で設定
  Dim slc As String     'Selection句
  Dim frm As String     'From句
  Dim whr As String     'Where句
  Dim ord As String     'Order by句
    
  'SQL変数の初期設定
  slc = "Select 番号,氏名,住所,所属,合計 "
  frm = "From 氏名テーブル S, 住所テーブル T "
  whr = "Where S.住所コード = T.住所コード"
  ord = ";"
  
  '条件付きを選択の時
  If OptionButton2 = True Then
  
    '氏名の選択条件
    If CheckBox1 = True Then
      If Len(TextBox1.Text) = 0 Then
        Beep
        MsgBox "検索文字を入力せよ."
        Exit Sub
      End If
      whr = whr & " and 氏名 like '%" _
            & TextBox1.Text & "%'"
    End If
    
    '住所の選択条件
    If CheckBox2 = True Then
      If ComboBox2.Value = "" Then
        Beep
        MsgBox "住所を選択せよ."
        Exit Sub
      End If
      whr = whr & " and T.住所コード = " _
            & Left(ComboBox2.Value, 2)
    End If
    
    '所属の選択条件( "'" に注意)
    If CheckBox3 = True Then
      If ComboBox3.Value = "" Then
        Beep
        MsgBox "所属を選択せよ."
        Exit Sub
      End If
      whr = whr & " and 所属 = " & _
            "'" & ComboBox3.Value & "'"
    End If
    
    '合計の選択条件
    If CheckBox4 = True Then
      If ComboBox4.Value = "" Then
        Beep
        MsgBox "合計を入力せよ."
        Exit Sub
      End If
      Select Case ComboBox4.ListIndex
        Case 0
          whr = whr & " and 合計 >= "
        Case 1
          whr = whr & " and 合計 < "
      End Select
      
      '点数設定
      whr = whr & TextBox4.Value
    End If
  End If
  
  '表示順序の指定
  If CheckBox5 = True Then
    Select Case ComboBox5.ListIndex
      Case 0
        ord = " Order by 番号 asc;"
      Case 1
        ord = " Order by 番号 desc;"
      Case 2
        ord = " Order by T.住所コード asc;"
      Case 3
        ord = " Order by T.住所コード desc;"
      Case 4
        ord = " Order by 合計 asc;"
      Case 5
        ord = " Order by 合計 desc;"
    End Select
  Else
    ord = " Order by 番号 asc;"
  End If
  
  '検索を実行しエクセルシートに転記
  'SQLを実行
  RcQ.Open slc & frm & whr & ord, Dbs
  
  'セルのクリア
  Cells.Clear
  'エクセル１行目にヘッダーを表示
  Cells(1, 1) = "番号"
  Cells(1, 2) = "氏名"
  Cells(1, 3) = "住所"
  Cells(1, 4) = "所属"
  Cells(1, 5) = "合計"
  
  '検索結果をシートに転記
  Rcd = 2  'エクセルのレコード表示行
  Do Until RcQ.EOF
    Cells(Rcd, 1) = RcQ!番号
    Cells(Rcd, 2) = RcQ!氏名
    Cells(Rcd, 3) = RcQ!住所
    Cells(Rcd, 4) = RcQ!所属
    Cells(Rcd, 5) = RcQ!合計
    Rcd = Rcd + 1
    RcQ.MoveNext
  Loop
  Worksheets(1).Columns("A:E").AutoFit
  
  'RcQレコードセットを閉じる
  RcQ.Close
End Sub
'---------------------------------

Private Sub CommandButton2_Click()
  'セルとボックス内のクリア
  Cells.Clear
  TextBox1.Text = ""
  TextBox4.Text = ""
  ComboBox2.ListIndex = -1
  ComboBox3.ListIndex = -1
  ComboBox4.ListIndex = -1
  ComboBox5.ListIndex = 0
  OptionButton1.Value = True
  CheckBox1.Enabled = False
  CheckBox2.Enabled = False
  CheckBox3.Enabled = False
  CheckBox4.Enabled = False
End Sub
'---------------------------------

Private Sub CommandButton3_Click()
  '終了
  Unload Me
End Sub
'---------------------------------

ADO その２ へ戻る.　　　　　　　　　　　　　　　　　　　　　　　　　　　　back top