VBAからGDI+を使う資料集
inet上の達人の方々から御教示いただいたコードを少しアレンジさせてもらっています（切り貼りとも言います）。
  1. ホーム
  2. Other
  3. exceltable


エクセルのテーブルからAccessデータベースに接続して、データを取得してみた

エクセルのテーブルの機能で、Accessのデータベースに接続してデータを取得できる事を知り使ってみた。
でも、Accessのテーブルや、既存のクエリーからデータを取得するだけなのに飽き足らなくなって、
Excel VBAからアクセスのクエリの抽出条件の変更を試みた。
一応は出来たけれど、エクセルのテーブルはAccessのデータベースに接続すると、占有してしまう事が分かった。
Accessにエクセルテーブルから接続した状態でAccessデータベースを開こうとすると、読み取り専用で開かれるし
逆にAccessデータベースを開いた状態でエクセルの接続ファイルを開くと、接続更新の際にエラーになる。
「このデータベースは、マシン 'hoge' のユーザー 'Admin' が開いています。データベースが使用可能になった時点で、再度実行してください。」

結局VBA使いにとっては、ADOやDAOで接続する方が、Accessデータベースを占有せず、使い勝手が良い事が分かった。
AccessDBに接続したテーブル(QueryTable?)を生成するコード(ADOでクエリの条件設定用テーブル操作を含む）と、
どうせADOを使うなら、やっぱりADOオンリーの方が良いじゃん。ということで、RecordSetを貼り付け後、
テーブル(LinkObject)に変換するコードを載せます。 


'Microsoft ActiveX Data Objects x.x Library に参照設定

'====================================================
'Access側で抽出期間設定用のTableを抽出条件に用いたクエリを作成しておく
'抽出期間設定用のTableは、抽出開始日と抽出終了日の二つのフィールドを持ち、使用都度レコード全削除後、一レコードのみ収納する。
'エクセルからADOで抽出期間設定用のTableに条件を設定後、エクセルのテーブルから、その条件を用いたクエリに接続する。
'エクセルでTableがACCDBに接続していると、ADOでのアクセスが出来ない様なので、一旦Tableのリンク削除、テーブル削除後、
'抽出用テーブルに値を設定し、クエリをデータソースにしたTableを設定する
'そのテーブルを元にグラフを更新する。（グラフ用のシートにグラフが一個だけ貼り付けてある事が前提）
'DAOでQueryDefしても同じだけどね...
	
Sub changeQueryCondition()
  Dim con      As New ADODB.Connection
  Dim rs       As New ADODB.Recordset
  Dim myDataSource      As String
  Dim sourcefilename As String
  Dim destSh As Worksheet
  Dim graphSh As Worksheet
  Dim mySQL As String
  Dim myStartDate As String, myEndDate As String
  Dim myTable As ListObject
  Dim myTableName As String
  Dim myTableRange As Range
  Dim i As Long
  
  Const dataSheetName As String = "Sheet4"
  Const graphSheetName As String = "Sheet3"
  Const periodStartAddress As String = "$N$2"
  Const periodEndAddress As String = "$N$4"
  
  sourcefilename = "20150620抽出テストデータ.accdb"
  myDataSource = ThisWorkbook.Path & "\" & sourcefilename
  myTableName = "myTable2"
  Set destSh = ThisWorkbook.Sheets(dataSheetName)
  Set graphSh = ThisWorkbook.Sheets(graphSheetName)
  
  'check myTable1 exists
  Set myTable = destSh.Range("A1").ListObject
  If Not myTable Is Nothing Then
    If myTable.Name = myTableName Then myTable.Delete
  End If
  'date error check
  With graphSh
    myStartDate = .Range(periodStartAddress).Value
    myEndDate = .Range(periodEndAddress).Value
    If (Not IsDate(myStartDate)) Or (Not IsDate(myEndDate)) Then Exit Sub
    If DateValue(.Range(periodStartAddress).Value) >= DateValue(.Range(periodEndAddress).Value) Then Exit Sub
  End With
   
  'カレントディレクトリのデータベースパスを取得
  myDataSource = ThisWorkbook.Path & "\" & sourcefilename
  'エクセルのテーブルを削除
  On Error Resume Next
  myTableName = "テーブル__" & sourcefilename
  destSh.ListObjects(myTableName).Unlink
  destSh.ListObjects(myTableName).Delete
  On Error GoTo 0
  
  'データベースに接続する
  con.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;" _
                      & "Data Source=" & myDataSource & ""
  con.Open
  
  con.Execute "DELETE * FROM T_period;"
  'endというフィールド名を用いると、INSERT文の誤りという訳の分からんエラーが出た
  'SQLでもendというのは何か意味を持つ様だ
  mySQL = "INSERT INTO T_period (startDate,endDate) VALUES (#myStartDate#,#myEndDate#);"
  mySQL = Replace(mySQL, "myStartDate", myStartDate)
  mySQL = Replace(mySQL, "myEndDate", myEndDate)
  
  con.Execute mySQL
  con.Close
  Set con = Nothing
  
  DoEvents: DoEvents: DoEvents
  
  'クエリに接続したテーブル(エクセルの)を作成
  makeLinkedTable myDataSource, "Q_selectWithDate", destSh.Range("A1")
  destSh.Range(myTableName).Columns(1).Cells.NumberFormatLocal = "yyyy/m/d h:mm;@"
  'redraw graph
  graphSh.ChartObjects(1).Chart.SetSourceData destSh.Range(myTableName)
End Sub


'ACCDBに接続したテーブルを生成する
'引数 ACCDBファイルへの絶対パス、対象とするテーブル・クエリ名、貼り付け先のセル）
Sub makeLinkedTable(myDataSource As String, Target As String, destCell As Range)
  Dim myQueryTable As QueryTable
  Dim myListObj As ListObject
  Dim currentSh As Worksheet
        
  Set currentSh = ActiveSheet
  Application.ScreenUpdating = False
  'TableはActivesheetにしか設けられないらしい
  destCell.Parent.Activate
  
'    https://msdn.microsoft.com/ja-jp/library/office/ff198271.aspx Officeデベロッパーセンター QueryTableオブジェクト

  Set myQueryTable = ActiveSheet.ListObjects.Add(SourceType:=0, Source:=Array( _
      "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;Password="""";User ID=Admin;Data Source=" & myDataSource _
      , ";Mode=Share Deny Write;Extended Properties="""";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password=""" _
      , """;Jet OLEDB:Engine Type=6;Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;" _
      , "Jet OLEDB:New Database Password="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;" _
      , "Jet OLEDB:Don't Copy Locale on Compact=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False;" _
      , "Jet OLEDB:Support Complex Data=False;Jet OLEDB:Bypass UserInfo Validation=False"), Destination:=destCell).QueryTable
        
  With myQueryTable
      .CommandType = xlCmdTable
      'これがリンクするクエリ（またはテーブル）指定箇所
      .CommandText = Array(Target)
      '行番号を含まない
      .RowNumbers = False
      'クエリ テーブルを更新するとき、指定されたクエリ テーブルの右側の数式を自動的に更新しない
      .FillAdjacentFormulas = False
      '先頭の 5 行のデータに共通する書式をクエリ テーブルの新しい行のデータに適用
      .PreserveFormatting = True
      'ファイルオープン時に更新しない
      .RefreshOnFileOpen = False
      'バックグラウンドクエリ
      .BackgroundQuery = True
      '変更されたレコード（行）のデータ更新時の処理
      .RefreshStyle = xlInsertDeleteCells
      .SavePassword = False
      'ピボットテーブル レポートのデータをブックと共に保存
      .SaveData = True
      '列の幅を調整する
      .AdjustColumnWidth = True
      .RefreshPeriod = 0
      'クエリ テーブルが更新されるごとに列の並べ替え、フィルタ設定、レイアウト情報を保存(旧バージョン互換はfalse)
      .PreserveColumnInfo = True
      'ファイル ベースのDB (Accessなど) の場合ソース データ ファイルの絶対パスが含まれる
      .SourceDataFile = myDataSource
      .ListObject.DisplayName = "テーブル__" & Right(myDataSource, Len(myDataSource) - InStrRev(myDataSource, "\"))

      .Refresh BackgroundQuery:=False
  End With
  currentSh.Activate
  Application.ScreenUpdating = True
End Sub

'====================================================
'結局普通にADOで全部やる方が、ACCDBを占有する事も無くGood

Sub extract()
  Dim con As ADODB.Connection
  Dim rs As ADODB.Recordset
  Dim myDataSource As String
  Dim sourcefilename As String
  Dim destSh As Worksheet
  Dim graphSh As Worksheet
  Dim mySQL As String
  Dim myStartDate As String, myEndDate As String
  Dim myTable As ListObject
  Dim myTableName As String
  Dim myTableRange As Range
  Dim i As Long
  
  Const dataSheetName As String = "Sheet2"
  Const graphSheetName As String = "Sheet1"
  Const periodStartAddress As String = "$N$2"
  Const periodEndAddress As String = "$N$4"
  
  sourcefilename = "20150620抽出テストデータ.accdb"
  myDataSource = ThisWorkbook.Path & "\" & sourcefilename
  myTableName = "myTable1"
  Set destSh = ThisWorkbook.Sheets(dataSheetName)
  Set graphSh = ThisWorkbook.Sheets(graphSheetName)
  
  'check myTable1 exists
  Set myTable = destSh.Range("A1").ListObject
  If Not myTable Is Nothing Then
    If myTable.Name = myTableName Then myTable.Delete
  End If
  'date error check
  With graphSh
    myStartDate = .Range(periodStartAddress).Value
    myEndDate = .Range(periodEndAddress).Value
    If (Not IsDate(myStartDate)) Or (Not IsDate(myEndDate)) Then Exit Sub
    If DateValue(.Range(periodStartAddress).Value) >= DateValue(.Range(periodEndAddress).Value) Then Exit Sub
  End With
  
  Set con = New ADODB.Connection
  Set rs = New ADODB.Recordset
  rs.CursorLocation = adUseClient 'for Use recordcount
  
  'connection
  con.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & myDataSource
  con.Open
  
  'make SQL
  mySQL = "SELECT dateAndTime, Data1, Data2, Data3 FROM T_table1 WHERE ((dateAndTime)>=#myStartDate# And (dateAndTime)<=#myEndDate#);"
  mySQL = Replace(mySQL, "myStartDate", myStartDate)
  mySQL = Replace(mySQL, "myEndDate", myEndDate)
  
  rs.Open mySQL, con, adOpenKeyset, adLockReadOnly
  
  With destSh
    'Column Header
    For i = 1 To rs.Fields.Count
      .Cells(1, i).Value = rs.Fields(i - 1).Name
    Next i
    
    .Cells(2, 1).CopyFromRecordset rs
    Set myTableRange = .Range("A1").Resize(rs.RecordCount, rs.Fields.Count) ' - 1)
    myTableRange.Columns(1).Cells.NumberFormatLocal = "yyyy/m/d h:mm;@"
  End With
  Set myTable = destSh.ListObjects.Add(xlSrcRange, myTableRange, , xlYes)
  myTable.Name = myTableName
  
  'redraw graph
  'graphSh.ChartObjects(1).Chart.SetSourceData myTableRange
  
  'Using structured references
  With graphSh.ChartObjects(1).Chart
   .SetSourceData destSh.Range(myTableName & "[#Data]")
    For i = 1 To .SeriesCollection.Count
     'Headerにおける列指定は列見出しの文字列でしかできないらしい　destSh.Range(myTableName & "[[#Headers],[FieldName1]]") みたいな
     .SeriesCollection(i).Name = destSh.Range(myTableName & "[#Headers]").Cells(i + 1)
      Next i
  End With
errHandle:
  
  If rs.State = 1 Then rs.Close
  Set rs = Nothing
  If con.State = 1 Then con.Close
  Set con = Nothing
  
End Sub