Access や CSV のファイルから、SQL で指定してデータを抽出できます。
表形式のデータであればエクセルのシートのデータも扱えて、同じ Book であれば、複数の表形式のデータを結合して新しい表を作成することもできます。
(但し、1フィールド当たり256文字の文字制限などがあります)
Connection ストリングを整理して、レコードセットとしてデータを取得できるように関数を書きました。
ファイル名か SQL 文でデータソースを判別するようにしました。
取得したレコードセットは、GetRows で配列に読み込んだり、CopyFromRecordset でワークシートに張ったりできます。
サンプルコード
ヘッダーの指定の仕方が YES/NO の方が良いような気もするけど、取りあえずこんな感じ。'=========================================================================' Function GetRecordset( _ ByVal pSQL As String, _ ByVal pFullname As String, _ Optional ByVal pHeader As Boolean _ ) As Object '=========================================================================' Dim buff As Variant Dim sPath As String Dim sHDR As String Dim sProvider As String Dim sDataSource As String Dim sExtProperties As String Dim objConnection As Object Dim objRecordSet As Object Dim ErrMessage As String Dim sConString As String 'ADO 定数(非参照設定)' Const adOpenStatic = 3 Const adLockOptimistic = 3 Const adCmdText = 1 Set objConnection = CreateObject("ADODB.Connection") Set objRecordSet = CreateObject("ADODB.Recordset") '必須チェック' Select Case True Case InStr(pFullname, "SQLOLEDB") = 0 '何もしない' Case pSQL = "" ErrMessage = "SQL文が空白です" GoTo RaiseError Case pFullname = "" ErrMessage = "ファイルのフルパスが空白です" GoTo RaiseError End Select 'ファイル存在チェック' If Dir(pFullname) = "" Then ErrMessage = "ファイルが見つかりません" GoTo RaiseError End If '下準備' sHDR = IIf(pHeader, "HDR=YES", "HDR=NO") buff = Dir(pFullname) sPath = Replace(pFullname, buff, "") 'CSV用ファイルパス' 'データソースの判定' Select Case True Case InStr(pSQL, ".csv") > 0, InStr(pSQL, ".txt") > 0 sExtProperties = "Text; FMT=Delimited;" & sHDR sDataSource = sPath Case InStr(pFullname, "xls") > 0 sExtProperties = "Excel 12.0; IMEX=1;" & sHDR sDataSource = pFullname Case InStr(pFullname, "accdb") > 0, InStr(pFullname, "mdb") > 0 sDataSource = pFullname Case InStr(pFullname, "SQLOLEDB") > 0 sDataSource = "SQLServer" sConString = pFullname Case Else ErrMessage = "データソースを判定できません" GoTo RaiseError End Select 'DB オープン' If sDataSource <> "SQLServer" Then With objConnection .Provider = "Microsoft.ACE.OLEDB.12.0" .Properties("Extended Properties") = sExtProperties .Properties("Data Source") = sDataSource .Open End With Else objConnection.Open sConString End If 'RecordSet オープン' objRecordSet.Open pSQL, objConnection, adOpenStatic, adLockOptimistic, adCmdText 'リターン' Set GetRecordset = objRecordSet Exit Function RaiseError: Err.Raise 999, "Function getRecordset", ErrMessage End Function
使用方法サンプル
Sub testCSV() Dim sSQL As String Dim sFullname As String Dim bHeader As Boolean Dim rs As Object sSQL = "SELECT * FROM Test.csv" sFullname = "C:\Users\user\Desktop\Test.csv" bHeader = True Set rs = GetRecordset(sSQL, sFullname, bHeader) End Sub Sub testExcel() Dim sSQL As String Dim sFullname As String Dim bHeader As Boolean Dim rs As Object sSQL = "SELECT * FROM [表紙$B3:G7]" sFullname = "C:\Users\user\Desktop\Test.xlsm" bHeader = True Set rs = GetRecordset(sSQL, sFullname, bHeader) End Sub Sub testAccess() Dim sSQL As String Dim sFullname As String Dim rs As Object sSQL = "SELECT * FROM Table1" sFullname = "C:\Users\user\Desktop\Database1.accdb" Set rs = GetRecordset(sSQL, sFullname) End Sub Sub testSQLServer() Dim sSQL As String Dim sCnString As String Dim rs As Object sSQL = "SELECT * FROM Table1" sCnString = "PROVIDER=SQLOLEDB;DATA SOURCE=SQLSERVER-01;UID=UserID;PWD=PassWord;DATABASE=USER_DB" Set rs = GetRecordset(sSQL, sCnString) End Sub
0 件のコメント:
コメントを投稿