演習32 と同様、最初に Excel VBA の VBエディタ において、次の設定を行う。
 VBE - ツール - 参照設定 - (レ)Microsoft DAO 3.6 Object Library

標準モジュールに、以下のプロシージャを記述し実行すると、Access のデータ
ベースファイルを自動的に新規作成し、さらに新規作成したテーブルに Excel
のシート上のデータを転記することができる。


　　==＞　


Sub Excel_Access5()
  Dim Ndbs As DAO.Database    'アクセス ファイル設定
  Dim Ntbl As DAO.TableDef    'アクセス テーブル定義
  Dim Nfld As DAO.Field       'アクセス フィールド定義
  Dim Nrcs As DAO.Recordset   'アクセス フィールド定義
  Dim wks As Excel.Worksheet  'エクセル シート指定
  Dim mtr As Variant          'エクセル 全データ
  Dim rcd As Integer          'アクセス 行指定
  Dim fld As Integer          'アクセス 列指定
  '例として acctest3.mdb を C:\直下に新規作成する
  'ファイルおよびテーブル・フィールドも新規作成する

  '新規: acctest3.mdb, テーブル5, 数値Ｄ, 数値Ｅ, 文字Ｆ
  Set wks = ThisWorkbook.Worksheets("Sheet1")
  Set Ndbs = CreateDatabase("C:\acctest3.mdb", dbLangJapanese)
  Set Ntbl = Ndbs.CreateTableDef("テーブル5")
  
  Set Nfld = Ntbl.CreateField("数値Ｄ", dbInteger)
  Ntbl.Fields.Append Nfld     'フィールドをテーブルに新規追加
                              '整数型(dbInteger)
                           
  Set Nfld = Ntbl.CreateField("数値Ｅ", dbInteger)
  Ntbl.Fields.Append Nfld     'フィールドをテーブルに新規追加
                              '整数型(dbInteger)
                           
  Set Nfld = Ntbl.CreateField("文字Ｆ", dbText, 60)
  Ntbl.Fields.Append Nfld     'フィールドをテーブルに新規追加
                              '文字型(dbText)
                           
  Ndbs.TableDefs.Append Ntbl  'テーブルにデータを転送する
  Set Nrcs = Ndbs.OpenRecordSet("テーブル5", dbOpenTable)
                              'テーブルを開く
  'For rcd = 2 To 6
  '  With Nrcs
  '    .AddNew
  '    !数値Ｄ = wks.Cells(rcd, 1)
  '    !数値Ｅ = wks.Cells(rcd, 2)
  '    !文字Ｆ = wks.Cells(rcd, 3)
  '    .Update
  '  End With
  'Next
  
  With wks
    With .Range("A1").CurrentRegion
    'エクセルシート全データ範囲(２次元配列)
    Let mtr = .Resize(.Rows.Count - 1).Offset(1, 0).Value
      For rcd = LBound(mtr, 1) To UBound(mtr, 1)   '1次行
        Nrcs.AddNew  'LB:最小値(1) UB:最大値(5)
        For fld = LBound(mtr, 2) To UBound(mtr, 2) '2次列
          'アクセスに行列でデータを書き込む
          Let Nrcs.Fields(fld - 1).Value = mtr(rcd, fld)
        Next
        Nrcs.Update  'データを保存する
      Next
    End With
  End With
  
  Nrcs.Close
  Ndbs.Close
  Set Ndbs = Nothing
  Set Nrcd = Nothing
  Set Nfld = Nothing
  Set Ntbl = Nothing
End Sub


DAO その２ へ戻る.　　　　　　　　　　　　　　　　　　　　　　　　　　　　back top