データ書き込みは

Call ADO_会社情報_書

データ読み込みは

Call ADO_会社情報_読


■Module0(設定用モジュール)

'ADO
Public Const Prv_Jet40 = "Provider=Microsoft.Jet.OLEDB.4.0;"

'Access DB
Public Const AccDB = "zmc.mdb"

■Module1

Option Explicit

Dim CN As ADODB.Connection
Dim RS As ADODB.Recordset

Sub ADO_会社情報_読()
    Call ADO_基本(1)
End Sub

Sub ADO_会社情報_書()
    Call ADO_基本(2)
End Sub

Sub ADO_基本(myNo As Long)
    Dim strProvider As String, strDataSource As String
    Dim myPath As String
    
    On Error GoTo ErrCheck
    
    'カレントフォルダへのパスの初期化
    myPath = ThisWorkbook.Path
    ChDrive myPath
    ChDir myPath
    
    Set CN = New ADODB.Connection
    
    strDataSource = "Data Source=" & myPath & "\" & AccDB
    strProvider = Prv_Jet40 & strDataSource
    
    With CN
        .ConnectionString = strProvider
        .Open
    End With
    
    Select Case myNo
    
        Case 1
            Call ADO_1
    
        Case 2
            Call ADO_2
    
    End Select
    
    
    '-------------------
    'レコードセットとDBコネクションを閉じ、オブジェクト破棄
    
DB_Close:
    
    RS.Close: CN.Close
    Set RS = Nothing: Set CN = Nothing
    
    Exit Sub
    
ErrCheck:

   MsgBox Err.Description
   Resume DB_Close

End Sub

Sub ADO_1()
'DBからレコードを取り出す
    
    Set RS = New ADODB.Recordset
    
    With RS
        'テーブルでもクエリでも同じように取り出せる
        .Source = "SELECT * FROM tbl会社情報;"
        .ActiveConnection = CN
        .Open
    End With
       
    '-------------------
    
    If Not (RS.EOF And RS.BOF) Then
    
        'レコードをシートに転記
        With Sheets(shtSet)
            .Range("C2").Value = RS("社名")
            .Range("C4").Value = RS("自年号")
            .Range("D4").Value = RS("自年")
            .Range("F4").Value = RS("自月")
            .Range("H4").Value = RS("自日")
            .Range("C5").Value = RS("至年号")
            .Range("D5").Value = RS("至年")
            .Range("F5").Value = RS("至月")
            .Range("H5").Value = RS("至日")
            .Range("C7").Value = RS("業種")
        End With
    
    End If

End Sub

Sub ADO_2()
'DBのレコードを変更書込みする(新規の場合はAddNewする)
    
    Set RS = New ADODB.Recordset
    
    With RS
        'テーブルでもクエリでも同じように取り出せる
        .Source = "SELECT * FROM tbl会社情報;"
        .ActiveConnection = CN
        .CursorType = adOpenKeyset
        .LockType = adLockOptimistic
        .Open
    End With
       
    '-------------------
    
    If RS.EOF And RS.BOF Then RS.AddNew
    
    'レコードをシートに転記
    With Sheets(shtSet)
        RS("社名") = .Range("C2").Value
        RS("自年号") = .Range("C4").Value
        RS("自年") = .Range("D4").Value
        RS("自月") = .Range("F4").Value
        RS("自日") = .Range("H4").Value
        RS("至年号") = .Range("C5").Value
        RS("至年") = .Range("D5").Value
        RS("至月") = .Range("F5").Value
        RS("至日") = .Range("H5").Value
        RS("業種") = .Range("C7").Value
    End With
    
    RS.Update