プログラミングのメモ

プログラミングの学び直し備忘録

トップ > ExcelVBA > VBA：Excel ：ADO：Access

VBA：Excel ：ADO：Access

ExcelVBA

第4話 DAOとADOの違い【連載】実務で使えるAccessのコツ - itstaffing エンジニアスタイル

配列？構造体？いやレコードセットでしょ！エクセルVBA - ぼくLog

AccessVBAの基本

https://sowel.co.jp/PDF_file/VB6/HowToUseRecordSet.pdf

DB Class化

プロパティ

■clsAccDB

Option Explicit

Private Const sPROVIDER_ As String = "Microsoft.ACE.OLEDB.12.0"

Private sDataSrc_ As String
Private sTbName_ As String

Private dmy_

' // データソース
Property Get pDataSrc() As String
    pDataSrc = sDataSrc_
End Property

Property Let pDataSrc(sDataSrc As String)
    sDataSrc_ = sDataSrc
End Property

' // テーブル名
Property Get pTbName() As String
    pTbName = sTbName_
End Property

Property Let pTbName(sTbName As String)
    sTbName_ = sTbName
End Property

DB作成、削除

■clsAccDB

'***************************************************
'* DB作成
'*
'*
'* @Arg01 {}
'* @Arg02 {}
'* @Ret   {}
'* @Note
'*
'***************************************************
Sub mthDB_Create()

    '参照設定:Microsoft ADO Ext.6.0 for DDL and Security
                    
    Dim cat As ADOX.Catalog
    Dim ConStr As String
    
    On Error GoTo ErrHandler
    
    '新規作成するデータベースのパスと名前
    
    'Access 2007以降（accdb ファイル）
    ConStr = "Provider=" & sPROVIDER_ & ";" _
                & " Data Source=" & sDataSrc_
    
    
    'Access 2003以前（mdb ファイル）
    'DBFile = ActiveWorkbook.Path & "\mydb2.mdb"
    'ConStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sDataSrc_
    
    Set cat = New ADOX.Catalog
    cat.Create ConStr
    
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Number & vbCrLf & Err.Description
    End If
    
    Set cat = Nothing

End Sub

  
'***************************************************
'* DB削除
'*
'*
'* @Arg01 {}
'* @Arg02 {}
'* @Ret   {}
'* @Note
'*
'***************************************************
Sub mthDB_Delete()

    Dim FSO As FileSystemObject
    Set FSO = New FileSystemObject
    
    FSO.DeleteFile (sDataSrc_)
    
    Set FSO = Nothing
    
    
End Sub

'***************************************************
'* DB存在確認
'*
'*
'* @Arg01 {}
'* @Arg02 {}
'* @Ret   {}
'* @Note
'*
'***************************************************
Function mthDB_IsExists() As Boolean

    Dim FSO As FileSystemObject
    Set FSO = New FileSystemObject
    
    mthDB_IsExists = FSO.FileExists(sDataSrc_)
    
    Set FSO = Nothing
    
    
End Function

■modAccDB

'***************************************************
'* CraateDB
'*
'* @Arg01 {}
'* @Arg02 {}
'* @Ret   {}
'* @Note
'*
'***************************************************
Public Sub mthDB_Create()

    Dim c As clsAccDB
    Set c = New clsAccDB
    
    c.pDataSrc = ThisWorkbook.Path & "\test.accdb"

    If c.mthDB_IsExists Then
        Call c.mthDB_Delete
    End If
    
    Call c.mthDB_Create

End Sub

'***************************************************
'* DeleteDB
'*
'* @Arg01 {}
'* @Arg02 {}
'* @Ret   {}
'* @Note
'*
'***************************************************
Public Sub mthDB_Delete()

    Dim c As clsAccDB
    Set c = New clsAccDB
    
    c.pDataSrc = ThisWorkbook.Path & "\test.accdb"

    If c.mthDB_IsExists Then
        Call c.mthDB_Delete
    End If

End Sub

TB 存在確認、作成、削除

TB存在確認

'***************************************************
'* [cls]TB存在確認
'*
'* @Arg01 {}
'* @Arg02 {}
'* @Ret   {}
'* @Note
'*
'***************************************************
Public Function mthTB_IsExist()
 
    '参照設定:Microsoft ADO Ext.6.0 for DDL and Security
    
    
    mthTB_IsExist = False
    
    Dim cat As ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim ConStr As String
    
    On Error GoTo ErrHandler
    
    'データベースのパスと名前
    
    'Access 2007以降（accdb ファイル）
    ConStr = "Provider=" & sPROVIDER_ & ";" _
                & " Data Source=" & sDataSrc_
    
    
    'Access 2003以前（mdb ファイル）
    'DBFile = ActiveWorkbook.Path & "\mydb2.mdb"
    'ConStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sDataSrc_
    
    'データベース接続
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = ConStr
    
    'テーブルの確認
    For Each tbl In cat.Tables
        Select Case tbl.Type
            Case "TABLE"
                If tbl.Name = sTbName_ Then
                    mthTB_IsExist = True
                    Exit Function
                End If
            End Select
    Next tbl
    
    
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Number & vbCrLf & Err.Description
    End If
    
    Set cat = Nothing
    Set tbl = Nothing
 
End Function

TB作成

'***************************************************
'* [cls]TB作成
'*
'* @Arg01 {}
'* @Arg02 {}
'* @Ret   {}
'* @Note
'*
'***************************************************
Public Sub mthTB_Create( _
                        ByVal dic_Fld As Dictionary _
                        )
 
    '参照設定:Microsoft ADO Ext.6.0 for DDL and Security
    
    Dim cat As ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim ConStr As String
    
    On Error GoTo ErrHandler
    
    'データベースのパスと名前
    'Access 2007以降（accdb ファイル）
    ConStr = "Provider=" & sPROVIDER_ & ";" _
                & " Data Source=" & sDataSrc_
    
    'データベース接続
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = ConStr
    
    'テーブルの作成
    Set tbl = New ADOX.Table
    tbl.Name = sTbName_
    Set tbl.ParentCatalog = cat
    
    'フィールド（列）の設定
    Dim v
    For Each v In dic_Fld
        tbl.Columns.Append v, dic_Fld(v)
    Next v
    
    'テータベースへ登録
    cat.Tables.Append tbl
    
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Number & vbCrLf & Err.Description
    End If
    
    Set cat = Nothing
    Set tbl = Nothing
 
End Sub

'***************************************************
'* [mod]TB作成
'*
'* @Arg01 {}
'* @Arg02 {}
'* @Ret   {}
'* @Note
'*
'***************************************************
Public Sub mthTB_Create()
 
    '参照設定:Microsoft ADO Ext.6.0 for DDL and Security
    
    '-------------------------------------------------------------------------
    Dim dic_Fld As Dictionary
    Set dic_Fld = New Dictionary
        
    'フィールド（列）の設定
    dic_Fld.Add "登録ID", adInteger
    dic_Fld.Add "氏名", adVarWChar
    dic_Fld.Add "生年月日", adDate
    dic_Fld.Add "備考", adLongVarWChar
    
    '-------------------------------------------------------------------------
    
    Dim c As clsAccDB
    Set c = New clsAccDB
    
    c.pDataSrc = ThisWorkbook.Path & "\test.accdb"
    c.pTbName = "TB_TEST"
    
    If Not c.mthTB_IsExist Then
        Call c.mthTB_Create(dic_Fld)
    End If
 
End Sub

TB削除

'***************************************************
'* [cls]TB削除
'*
'* @Arg01 {}
'* @Arg02 {}
'* @Ret   {}
'* @Note
'*
'***************************************************
Public Sub mthTB_Delete()
 
    Dim cat As ADOX.Catalog
    Dim tbl As ADOX.Table
    Dim ConStr As String
    
    On Error GoTo ErrHandler
    
    'データベースのパスと名前
    
    'Access 2007以降（accdb ファイル）
    ConStr = "Provider=" & sPROVIDER_ & ";" _
                & " Data Source=" & sDataSrc_
    
    'データベース接続
    Set cat = New ADOX.Catalog
    cat.ActiveConnection = ConStr
    
    'テーブルの削除
    cat.Tables.Delete sTbName_
    
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Number & vbCrLf & Err.Description
    End If
    
    Set cat = Nothing
    Set tbl = Nothing
 
End Sub

'***************************************************
'* [mod]TB削除
'*
'* @Arg01 {}
'* @Arg02 {}
'* @Ret   {}
'* @Note
'*
'***************************************************
Public Sub mthTB_Delete()
 
    Dim c As clsAccDB
    Set c = New clsAccDB
    
    c.pDataSrc = ThisWorkbook.Path & "\test.accdb"
    c.pTbName = "TB_TEST"
    
    If c.mthTB_IsExist Then
        Call c.mthTB_Delete
    End If

 
End Sub

INSERT

    Dim colc_mrg As Collection
    Set colc_mrg = New Collection
    
    Dim colc As Collection
    Set colc = New Collection
    
    colc.Add (Array("登録ID", 1))
    colc.Add (Array("氏名", "a"))
    colc.Add (Array("生年月日", "1971/1/1"))
    colc.Add (Array("備考", "note"))
    Call colc_mrg.Add(colc)
    
    
    Set colc = New Collection
    colc.Add (Array("登録ID", 2))
    colc.Add (Array("氏名", "b"))
    colc.Add (Array("生年月日", "1971/1/2"))
    colc.Add (Array("備考", "note2"))
    Call colc_mrg.Add(colc)
    
    Call c.mthInsert(colc_mrg)

'**
'* INSERT
'*
'* parg     {}
'* @arg_ref {}
'* @arg_opt {}
'* @ret     {}
'*
'* @note
'*
Sub mthInsert(colc As Collection)
 
    '==================
    ' 接続文字列
    '==================
    Dim cnstr As String
    cnstr = "Provider = " & sPROVIDER_ & ";" & _
            "Data Source = " & sDataSrc_ & ";"

    '==================
    ' 接続(cn)
    '==================
    Dim cn As ADODB.Connection
    Set cn = New ADODB.Connection
    
    cn.ConnectionString = cnstr
    cn.Open
    
    '================================
    ' レコードセット(rs SQL,DB)
    '================================
    Dim rs As ADODB.Recordset
    Set rs = New ADODB.Recordset
    
    rs.Open sTbName_, cn, adOpenDynamic, adLockOptimistic
    
    Dim r As Long
    Dim c As Long
    
    For r = 1 To colc.Count
        rs.AddNew
        
        For c = 1 To colc.Item(r).Count
'            Debug.Print colc.Item(r)(c)(0)
'            Debug.Print colc.Item(r)(c)(1)
            rs.Fields(colc.Item(r)(c)(0)) = colc.Item(r)(c)(1)
        Next c
        
        rs.Update
    Next r
    
    '================================
    ' CLOSE
    '================================
    rs.Close: Set rs = Nothing
    cn.Close: Set cn = Nothing

 
End Sub

Collection（Collection（（Array））

Sub dmy()

'        Dim arrFld(), arrVal()
'        ReDim arrFld(colc.Item(r).Count - 1)
'        ReDim arrVal(colc.Item(r).Count - 1)
        
        For c = 1 To colc.Item(r).Count
'            Debug.Print colc.Item(r)(c)(0)
'            Debug.Print colc.Item(r)(c)(1)
'            arrFld(c - 1) = colc.Item(r)(c)(0)
'            arrVal(c - 1) = colc.Item(r)(c)(1)
            rs.Fields(colc.Item(r)(c)(0)) = colc.Item(r)(c)(1)
        Next c
        
'        Dim sFld As String
'        Dim sVal As String
'        sFld = "([" & Join(arrFld, "],[") & "])"
'        sVal = "('" & Join(arrVal, "','") & "')"
'
'        'INSERT INTO syain(id,name,romaji) VALUES (1,'鈴木','suzuki');
'        Dim sSQL As String
'        sSQL = ""
'        sSQL = sSQL & "INSERT INTO " & sTbName_ & sFld
'        sSQL = sSQL & " VALUES" & sVal
'        sSQL = sSQL & ";"

End Sub

JOIN（FULL）

'**
'* FULL JOIN
'*
'* parg     {}
'* @arg_ref {}
'* @arg_opt {}
'* @ret     {}
'*
'* @note
'*
Sub mth_JoinFull()
 
    '==================
    ' 接続文字列
    '==================
    Dim cnstr As String
    cnstr = "Provider = " & sPROVIDER_ & ";" & _
            "Data Source = " & sDataSrc_ & ";"

    '==================
    ' 接続(cn)
    '==================
    Dim cn As ADODB.Connection
    Set cn = New ADODB.Connection
    
    cn.ConnectionString = cnstr
    cn.Open
    
    '================================
    ' レコードセット(rs SQL,DB)
    '================================
    Dim rs As ADODB.Recordset
    Set rs = New ADODB.Recordset
    
    '================================
    ' SQL
    '================================
    Dim sSQL As String
    sSQL = ""
    sSQL = sSQL & "SELECT"
    sSQL = sSQL & " [T1.File],[T2.File],[T1.Sheet1],[T2.Sheet2],[T1.Code],[T2.Code],"
    sSQL = sSQL & " [T1.Data01],[T1.Data02],[T2.Data11],[T2.Data12]"
    sSQL = sSQL & " FROM TB_01 AS T1"
    sSQL = sSQL & " LEFT JOIN TB_02 AS T2"
    sSQL = sSQL & " ON T1.File = T2.File"
    sSQL = sSQL & " AND T1.Code = T2.Code"
    sSQL = sSQL & " Union "
    sSQL = sSQL & "SELECT"
    sSQL = sSQL & " [T1.File],[T2.File],[T1.Sheet1],[T2.Sheet2],[T1.Code],[T2.Code],"
    sSQL = sSQL & " [T1.Data01],[T1.Data02],[T2.Data11],[T2.Data12]"
    sSQL = sSQL & " FROM TB_01 AS T1"
    sSQL = sSQL & " RIGHT JOIN TB_02 AS T2"
    sSQL = sSQL & " ON T1.File = T2.File"
    sSQL = sSQL & " AND T1.Code = T2.Code"

    rs.Open sSQL, cn, adOpenStatic
    
    #If Win64 Then
        Dim lRecord_Cnt As LongLong   ' 64ビット版のとき
    #Else
        Dim lRecord_Cnt As Long       ' 32ビット版のとき
    #End If
    
    Dim lField_Cnt As Long
    
    lRecord_Cnt = rs.RecordCount
    lField_Cnt = rs.Fields.Count
    
    ThisWorkbook.Worksheets("AccDB").Cells.ClearContents
    ThisWorkbook.Worksheets("AccDB").Range("A1").CopyFromRecordset rs  'RecordSetをシートに貼り付け
    
    rs.MoveFirst
    '================================
    ' RESULT
    '================================
    #If Win64 Then
        Dim r As LongLong   ' 64ビット版のとき
    #Else
        Dim r As Long       ' 32ビット版のとき
    #End If
    
    Dim c As Long
    
    lRecord_Cnt = rs.RecordCount
    lField_Cnt = rs.Fields.Count
    
    Dim colcRecordAll As Collection
    Set colcRecordAll = New Collection
    For r = 0 To lRecord_Cnt - 1
        Dim colcBuf As Collection
        Set colcBuf = New Collection
        For c = 0 To lField_Cnt - 1
            Dim vDatPair()
            Dim sFldName As String
            sFldName = rs.Fields.Item(c).Name
            
            Dim sData As String
            If IsNull(rs.Fields(sFldName)) Then
                sData = ""
            Else
                sData = rs.Fields(sFldName)
            End If
            
            vDatPair = Array(sFldName, sData)
            Call colcBuf.Add(vDatPair)
        Next c
        Call colcRecordAll.Add(colcBuf)
        rs.MoveNext
    Next r
    
    '================================
    ' CLOSE
    '================================
    rs.Close: Set rs = Nothing
    cn.Close: Set cn = Nothing

 
End Sub

接続文字列

Const sDataSorce As String = "D:\Northwind.accdb"
Const sPASS As String = "pass"

DB接続

'■■■■■■■■■■■■■■■■■■■■■■■■■
'// DB接続
'//
'■■■■■■■■■■■■■■■■■■■■■■■■■
Private Sub psub_DB接続()

    Call mth_OpenDB
    
End Sub

'*************************************************************************
'機能   : DB接続
'戻り値 :
'ARG1   :
'説明   :
'*************************************************************************
Public Sub mth_OpenDB()

    '==================
    ' 接続文字列
    '==================
    Dim cnstr As String
    cnstr = "Provider = Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source = " & sDataSorce & ";" & _
            "Jet OLEDB:Database Password = " & sPASS & ";"
    
    '==================
    ' 接続(cn)
    '==================
    Dim cn As ADODB.Connection
    Set cn = New ADODB.Connection
    cn.ConnectionString = cnstr
    cn.Open
    
    '================================
    ' CLOSE
    '================================
    cn.Close: Set cn = Nothing

    
End Sub

選択

SELECT [First Name],[Job Title] FROM Employees WHERE City = 'Seattle'

「Sales」を含む
SELECT [First Name],[Job Title] FROM Employees WHERE [Job Title] LIKE '%Sales%'
0文字以上：%
1文字：_

『SELECT』ByRef collect(FLD_NAME, Value)

'■■■■■■■■■■■■■■■■■■■■■■■■■
'// 『SELECT』テーブルの全データをシートに出力
'//
'■■■■■■■■■■■■■■■■■■■■■■■■■

'*********************************************************
'* SELECT
'*
'* parg     {}
'* @arg_ref {}
'* @arg_opt {}
'* @ret     {}
'*
'* @note
'*
'*********************************************************
Sub mth_Select( _
                ByVal sSQL As String, _
                ByRef Ref_colcDatas As Collection _
                )
 
    Dim i As Long
    
    'Ref_collection Delete
    For i = 1 To Ref_colcDatas.Count
        Ref_colcDatas.Remove 1
    Next i
    
    '## 接続文字列 #####################
    Dim cnstr As String
    cnstr = "Provider = " & sPROVIDER_ & ";" & _
            "Data Source = " & sDataSrc_ & ";"

    '## 接続(cn) #####################
    Dim cn As ADODB.Connection
    Set cn = New ADODB.Connection
    
    cn.ConnectionString = cnstr
    cn.Open
    
    '## レコードセット(rs SQL,DB) #####################
    Dim rs As ADODB.Recordset
    Set rs = New ADODB.Recordset
    
    rs.CursorLocation = adUseClient
    rs.Open sSQL, cn, adOpenDynamic, adLockReadOnly
    
    '## Result ##################
    If rs.RecordCount < 1 Then GoTo END_PROC
    
    Do Until rs.EOF
        Dim colcFldDats As Collection
        Set colcFldDats = New Collection
        
        For i = 0 To rs.Fields.Count - 1
            colcFldDats.Add Array(rs.Fields(i).Name, rs.Fields(rs.Fields(i).Name).Value)
        Next i
        
        Ref_colcDatas.Add colcFldDats
        Set colcFldDats = Nothing
        
        rs.MoveNext
    Loop
    
    '## CLOSE #######################################
    rs.Close
    cn.Close

END_PROC:
    Set rs = Nothing
    Set cn = Nothing
 
End Sub

『SELECT』テーブルの全データをシートに出力

'■■■■■■■■■■■■■■■■■■■■■■■■■
'// 『SELECT』テーブルの全データをシートに出力
'//
'■■■■■■■■■■■■■■■■■■■■■■■■■
Private Sub psub_テーブルデータをシートに出力()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)
    ws.Cells.Clear
    ws.Activate
    
    Dim rngStartCell As Range
    Set rngStartCell = ws.Range("B2")
    
    '// 処理
    Call mth_SelectAll_CopyFormRs(rngStartCell)
    ws.Cells.EntireColumn.AutoFit

    Set rngStartCell = Nothing
    Set ws = Nothing
    
End Sub

'*************************************************************************
'機能   : 『SELECT』テーブルの全データをシートに出力
'戻り値 :
'ARG1   :
'説明   :
'*************************************************************************
Public Sub mth_SelectAll_CopyFormRs(rngStartCell As Range)

    '==================
    ' 接続文字列
    '==================
    Dim cnstr As String
    cnstr = "Provider = Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source = " & sDataSorce & ";" & _
            "Jet OLEDB:Database Password = " & sPASS & ";"
    
    '==================
    ' 接続(cn)
    '==================
    Dim cn As ADODB.Connection
    Set cn = New ADODB.Connection
    cn.ConnectionString = cnstr
    cn.Open
    
    '================================
    ' レコードセット(rs SQL,DB)
    '================================
    Dim rs As ADODB.Recordset
    Set rs = New ADODB.Recordset
    
    Dim sSQL As String
    sSQL = "SELECT * FROM Employees"

    rs.Open sSQL, cn, adOpenStatic, adLockReadOnly
    
    '================================
    ' RESULT
    '================================
    rngStartCell.CopyFromRecordset rs
    
    '================================
    ' CLOSE
    '================================
    cn.Close: Set cn = Nothing

    
End Sub

『SELECT』フィールド指定：データをシートに出力

'■■■■■■■■■■■■■■■■■■■■■■■■■
'// 『SELECT』フィールド指定：データをシートに出力
'//
'■■■■■■■■■■■■■■■■■■■■■■■■■
Private Sub psub_フィールド指定_データをシートに出力()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)
    ws.Cells.Clear
    ws.Activate
    
    Dim rngStartCell As Range
    Set rngStartCell = ws.Range("B2")
    
    '// 処理
    Call mth_SelectFld_CopyFormRs(rngStartCell)
    ws.Cells.EntireColumn.AutoFit

    Set rngStartCell = Nothing
    Set ws = Nothing
    
End Sub

'*************************************************************************
'機能   : 『SELECT』フィールド指定：データをシートに出力
'戻り値 :
'ARG1   :
'説明   :
'*************************************************************************
Public Sub mth_SelectFld_CopyFormRs(rngStartCell As Range)

    '==================
    ' 接続文字列
    '==================
    Dim cnstr As String
    cnstr = "Provider = Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source = " & sDataSorce & ";" & _
            "Jet OLEDB:Database Password = " & sPASS & ";"
    
    '==================
    ' 接続(cn)
    '==================
    Dim cn As ADODB.Connection
    Set cn = New ADODB.Connection
    cn.ConnectionString = cnstr
    cn.Open
    
    '================================
    ' レコードセット(rs SQL,DB)
    '================================
    Dim rs As ADODB.Recordset
    Set rs = New ADODB.Recordset
    
    Dim sSQL As String
    sSQL = "SELECT [Last Name],[Job Title] FROM Employees"

    rs.Open sSQL, cn, adOpenStatic, adLockReadOnly
    
    '================================
    ' RESULT
    '================================
    rngStartCell.CopyFromRecordset rs
    
    '================================
    ' CLOSE
    '================================
    cn.Close: Set cn = Nothing

    
End Sub

『WHERE』条件_データをシートに出力

'■■■■■■■■■■■■■■■■■■■■■■■■■
'// 『WHERE』条件_データをシートに出力
'//
'■■■■■■■■■■■■■■■■■■■■■■■■■
Private Sub psub_条件_データをシートに出力()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)
    ws.Cells.Clear
    ws.Activate
    
    Dim rngStartCell As Range
    Set rngStartCell = ws.Range("B2")
    
    '// 処理
    Call mth_SelectWhere_CopyFormRs(rngStartCell)
    ws.Cells.EntireColumn.AutoFit

    Set rngStartCell = Nothing
    Set ws = Nothing
    
End Sub

'*************************************************************************
'機能   : 『WHERE』条件_データをシートに出力
'戻り値 :
'ARG1   :
'説明   :
'*************************************************************************
Public Sub mth_SelectWhere_CopyFormRs(rngStartCell As Range)

    '==================
    ' 接続文字列
    '==================
    Dim cnstr As String
    cnstr = "Provider = Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source = " & sDataSorce & ";" & _
            "Jet OLEDB:Database Password = " & sPASS & ";"
    
    '==================
    ' 接続(cn)
    '==================
    Dim cn As ADODB.Connection
    Set cn = New ADODB.Connection
    cn.ConnectionString = cnstr
    cn.Open
    
    '================================
    ' レコードセット(rs SQL,DB)
    '================================
    Dim rs As ADODB.Recordset
    Set rs = New ADODB.Recordset
    
    Dim sSQL As String
    sSQL = ""
    sSQL = sSQL & "SELECT * FROM [Order Details]"
    'sSQL = sSQL & " WHERE [Quantity] >= 100"

    rs.Open sSQL, cn, adOpenStatic, adLockReadOnly
    
    '================================
    ' RESULT
    '================================
    rngStartCell.CopyFromRecordset rs
    
    '================================
    ' CLOSE
    '================================
    cn.Close: Set cn = Nothing

    
End Sub

『LIKE』パタンマッチ_データをシートに出力

'■■■■■■■■■■■■■■■■■■■■■■■■■
'// 『LIKE』パタンマッチ_データをシートに出力
'//
'■■■■■■■■■■■■■■■■■■■■■■■■■
Private Sub psub_パタンマッチ_データをシートに出力()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)
    ws.Cells.Clear
    ws.Activate
    
    Dim rngStartCell As Range
    Set rngStartCell = ws.Range("B2")
    
    '// 処理
    Call mth_SelectLike_CopyFormRs(rngStartCell)
    ws.Cells.EntireColumn.AutoFit

    Set rngStartCell = Nothing
    Set ws = Nothing
    
End Sub

'*************************************************************************
'機能   : 『LIKE』パタンマッチ_データをシートに出力
'戻り値 :
'ARG1   :
'説明   : [%:0以上][_:1文字]
'*************************************************************************
Public Sub mth_SelectLike_CopyFormRs(rngStartCell As Range)

    '==================
    ' 接続文字列
    '==================
    Dim cnstr As String
    cnstr = "Provider = Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source = " & sDataSorce & ";" & _
            "Jet OLEDB:Database Password = " & sPASS & ";"
    
    '==================
    ' 接続(cn)
    '==================
    Dim cn As ADODB.Connection
    Set cn = New ADODB.Connection
    cn.ConnectionString = cnstr
    cn.Open
    
    '================================
    ' レコードセット(rs SQL,DB)
    '================================
    Dim rs As ADODB.Recordset
    Set rs = New ADODB.Recordset
    
    Dim sSQL As String
    sSQL = ""
    sSQL = sSQL & "SELECT [Last Name],[Job Title] FROM Employees"
    sSQL = sSQL & " WHERE [Job Title] Like 'Sales%'"

    rs.Open sSQL, cn, adOpenStatic, adLockReadOnly
    
    '================================
    ' RESULT
    '================================
    rngStartCell.CopyFromRecordset rs
    
    '================================
    ' CLOSE
    '================================
    cn.Close: Set cn = Nothing

    
End Sub

SELECT * FROM TB

'*************************************
' SELECT * FROM TB
'
'*************************************
Private Sub btn_04_05_DB接続_Click()

    '===========================
    '// 出力先 開始セル
    '===========================
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("RES")
    
    Dim ws_Range As Range
    Set ws_Range = ws.Range("A2")
    
    '===========================
    '// 実行
    '===========================
    Dim varrTB() As Variant
    varrTB = mth_0405_DB_Select(ws_Range)
 
    '===========================
    '// TB 2次元配列データ
    '===========================
    Dim lRow_Last As Long
    lRow_Last = ws.Cells(Rows.Count, 1).End(xlUp).Row
    
    Dim lRow As Long: lRow = UBound(varrTB, 1) - LBound(varrTB, 1) + 1
    Dim lCol As Long: lCol = UBound(varrTB, 2) - LBound(varrTB, 2) + 1
   
    ' Out 1
    ws.Range("A13", Cells(lRow - 1 + 13, lCol - 1)).Value = varrTB
    
    ' Out 2
    lRow_Last = ws.Cells(Rows.Count, 1).End(xlUp).Row
    ws.Range( _
                "A" & lRow_Last + 2, _
                ws.Range("A" & lRow_Last + 2).Offset(lRow - 1, lCol - 1)).Value = varrTB
    
    
End Sub

'*************************************
' SELECT * FROM TB
'
'*************************************
Function mth_0405_DB_Select(ByVal ws_Range As Range) As Variant()
 
    Dim lRecord As Long
    Dim lField As Long
    Dim varrTB() As Variant
     
    '==================
    ' 接続文字列
    '==================
    Dim cnstr As String
    cnstr = "Provider = Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source = " & "D:\Northwind.accdb;" & _
            "Jet OLEDB:Database Password = " & ps_PASS & ";"
    
    '==================
    ' 接続(cn)
    '==================
    Dim cn As ADODB.Connection
    Set cn = New ADODB.Connection
    cn.ConnectionString = cnstr
    cn.Open
    
    '================================
    ' レコードセット(rs SQL,DB)
    '================================
    Dim rs As ADODB.Recordset
    Set rs = New ADODB.Recordset
    
    Dim sSQL As String
    sSQL = "SELECT * FROM Employees"

    rs.Open sSQL, cn, adOpenStatic, adLockReadOnly
    
    '================================
    ' RESULT
    '================================
    Dim lRecord_Cnt As Long
    Dim lField_Cnt As Long
    
    lRecord_Cnt = rs.RecordCount
    lField_Cnt = rs.Fields.Count
    
    Dim vArr2D() As Variant
    
    '----------------------------------
    '　配列格納１
    '----------------------------------
    ReDim vArr2D(lRecord_Cnt - 1, lField_Cnt - 1)
    
    varrTB = rs.GetRows '※配列（列，行）　一括読込み
'    Dim vArr2D As Variant
'    '// Transpose : 配列に Null 値を含めることはできません。
'    vArr2D = WorksheetFunction.Transpose(varrTB)
    
    Dim iRec As Long
    Dim iCol As Long
    
    For iRec = LBound(varrTB, 2) To UBound(varrTB, 2)
        For iCol = LBound(varrTB, 1) To UBound(varrTB, 1)
            vArr2D(iRec, iCol) = varrTB(iCol, iRec)
        Next
    Next
    
    '----------------------------------
    '　配列格納２
    '----------------------------------
    ReDim vArr2D(lRecord_Cnt - 1, lField_Cnt - 1)
    
    rs.MoveFirst
    For iRec = 0 To lRecord_Cnt - 1
        For iCol = 0 To lField_Cnt - 1
            vArr2D(iRec, iCol) = rs.Fields.Item(iCol).Value
        Next
        rs.MoveNext
    Next
    
    '----------------------------------
    '　一括セル出力
    '----------------------------------
'    rs.MoveFirst
'    ThisWorkbook.Sheets("RES").Range("A2").CopyFromRecordset rs
    
    rs.MoveFirst
    ws_Range.CopyFromRecordset rs
    
    '----------------------------------
    '　フィールド名
    '----------------------------------
    Dim sFldName() As String
    ReDim sFldName(lField_Cnt - 1)
    
    rs.MoveFirst
    For iCol = 0 To lField_Cnt - 1
        sFldName(iCol) = rs.Fields.Item(iCol).Name
    Next
    
    '----------------------------------
    '　指定FLD レコード　配列格納
    '----------------------------------
    Dim vRecDat_1() As Variant  'nullを想定
    Dim vRecDat_2() As Variant
    ReDim vRecDat_1(lRecord_Cnt - 1)
    ReDim vRecDat_2(lRecord_Cnt - 1)
    
    rs.MoveFirst
    For iRec = 0 To lRecord_Cnt - 1
        vRecDat_1(iRec) = rs.Fields("Last Name")
        vRecDat_2(iRec) = rs.Fields("First Name")
        rs.MoveNext
    Next
    
    '================================
    ' CLOSE
    '================================
    rs.Close: Set rs = Nothing
    cn.Close: Set cn = Nothing
    
    '
    mth_0405_DB_Select = vArr2D
    
End Function