SIBAINUのメモ帳

外部のEXCELにADOで接続

COPY

Private Sub ByAdoExcel()
    Dim AdoCn As ADODB.Connection
    Dim AdoRs As ADODB.Recordset
    Dim strSQL As String

    On Error GoTo ERROR_SHORI

    ①-①-①Excel2007以降で作成したブックに接続する場合
    Set AdoCn = New ADODB.Connection
    With AdoCn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .Properties("Extended Properties") = "Excel 12.0;HDR=Yes;IMEX=1"
        .Open "対象となるExcelファイルのパスとファイル名"
    End With

    With AdoCn
        .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                            "Data Source=" & "対象となるExcelファイルのパスとファイル名 & ";"
                            "Extended Properties=Excel 12.0;HDR=Yes;IMEX=1"
        .Open
    End With

    ①-①-②Excel2002/2003で作成したブックに接続する場合

    With AdoCn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .Properties("Extended Properties") = "Excel 8.0;HDR=Yes;IMEX=1"
        .Open [対象となるExcelファイルのパスとファイル名]
    End With

    With AdoCn
        .ConnectionString = "Microsoft.Jet.OLEDB.4.0;" & _
                            "Data Source=" & [対象となるExcelファイルのパスとファイル名] & ";"
                            "Extended Properties=Excel 8.0;HDR=Yes;IMEX=1"
        .Open
    End With

    ①-②レコードセットの取得
　　'SQL文作成
　　strSQL = ""
　　strSQL = strSQL & " SELECT *"
　　strSQL = strSQL & " FROM"
　　strSQL = strSQL & " [シート名$]"
　　strSQL = strSQL & " WHERE 列名 = 'bb';"
    Set AdoRs = New ADODB.Recordset
    With AdoRs
        .adCmdText =strSQL
        .ActiveConnection = AdoCn
        .CursorType = adOpenStatic
        .LookType = adLockOptimistic
        .Option = adCmdText
        .Open
    End With

    AdoRs.Open strSQL, AdoCn, _
               adOpenStatic, adLockOptimistic, adCmdText

    '①-③ワークシートに貼り付ける
    Set Sh = ActiveSheet

    '①-③-①SQLを使う場合
    RC = 1
    Do Until AdoRs.EOF
        CC = 1
        For Each FD In AdoRs.Fields
            If RC = 1 Then
                Sh.Cells(RC, CC).Value = FD.Name
            Else
                Sh.Cells(RC, CC).Value = FD.Value
            End If
            CC = CC + 1  '列番号
        Next
        RC = RC + 1      '行番号
        DaoRs.MoveNext
    Loop

    '①-③-②EXCELのCopyFromRecordsetを使う場合
    For Each FD In AdoRs.Fields
        Sh.Cells(1, CC).Value = FD.Name
        CC = CC + 1  '列番号
    Next
    Sh.Cells(2, 1).CopyFromRecordset DaoRs


    '①のエラー処理
ERROR_SHORI:
    If Not AdoRs Is Nothing Then
        If AdoRs.State = adRecObjectOpen Then
            AdoRs.Close
        End If
        Set AdoRs = Nothing
    End If

    If Not AdoCn Is Nothing Then
        If AdoCn.State = adStateOpen Then
            AdoCn.Close
        End If
        Set AdoCn = Nothing
    End If
End Sub

AccessにADOで接続

COPY

Private Sub ByAdoAccess()
    Dim AdoCn As ADODB.Connection
    Dim AdoRs As ADODB.Recordset
    Dim strSQL As String
On Error GoTo ERROR_SHORI

    '②-①接続
    Set AdoCn = New ADODB.Connection
    Set AdoRs = New ADODB.Recordset

    AdoCn.ConnectionString = _
            "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=" & "対象となるAccessファイルのパスとファイル名"
    AdoCn.Open

    '②-②データを取得する
    Dim FD As Object
    Dim Sh As Worksheet
    Dim RC, CC As Long

    '②-②-①SQLの実行して、レコードセットの取得
    Set AdoRs = AdoCn.Execute("SELECT * FROM テーブル名;")
    'または
    '②-②-②SQLを使う場合
    AdoRs.Open strSQL, AdoRs, _
               adOpenForwardOnly, adLockPessimistic, adCmdText
    '②-②-③テーブルを使う場合
    AdoRs.Open "テーブル名", AdoRs, _
               adOpenForwardOnly, adLockPessimistic, adCmdTable

    '②-③ワークシートに貼り付ける
    Set Sh = ActiveSheet

    '②-③-①-①SQLを使う場合
    RC = 1
    Do Until AdoRs.EOF
        CC = 1
        For Each FD In AdoRs.Fields
            If RC = 1 Then
                Sh.Cells(RC, CC).Value = FD.Name
            Else
                Sh.Cells(RC, CC).Value = FD.Value
            End If
            CC = CC + 1  '列番号
        Next
        RC = RC + 1      '行番号
        DaoRs.MoveNext
    Loop

    '②-③-①-②EXCELのCopyFromRecordsetを使う場合
    For Each FD In AdoRs.Fields
        Sh.Cells(1, CC).Value = FD.Name
        CC = CC + 1  '列番号
    Next
    Sh.Cells(2, 1).CopyFromRecordset AdoRs

    '②-④更新・追加・削除の場合
    Dim RecordsAffected As Long

    AdoCn.BeginTrans
    strSQL = "INSERT INTO テーブル名(列名1,列名2,列名3) VALUES('val',1,'2010/01/01');"
    strSQL = "UPDATE テーブル名 SET 列名2 = 10 WHERE 列名2 = 1;"
    strSQL = "DELETE テーブル名 WHERE[列名1 = 'val';"
    AdoCn.Execute strSQL, RecordsAffected

    If RecordsAffected > 0 Then
        AdoCn.CommitTrans
    Else
        AdoCn.RollbackTrans
    End If

    '②のエラー処理
ERROR_SHORI:
    If Not AdoRs Is Nothing Then
        If AdoRs.State = adRecObjectOpen Then
            AdoRs.Close
        End If
        Set AdoRs = Nothing
    End If

    If Not AdoCn Is Nothing Then
        If AdoCn.State = adStateOpen Then
            AdoCn.Close
        End If
        Set AdoCn = Nothing
    End If
End Sub

AccessにDAOで接続

COPY

Private Sub ByDaoAccess()
    Dim DBE As DAO.DBEngine     'DAOのエンジン本体
    Dim DB As DAO.Database      'データベースオブジェクト
    Dim DaoRs As DAO.Recordset
    Dim strSQL As String

On Error GoTo ERROR_SHORI

    '③-①
    Set DBE = New DAO.DBEngine
    Set DB = DBE.OpenDatabase("C:¥Test¥Test.mdb")

    '③-②データを取得する場合
    '③-②-①SQLを使う場合
    Set DaoRs = DB.OpenRecordset("SELECT * FROM テーブル名;", dbOpenForwardOnly)
                他にdbOpenDynaset, dbOpenSnapshotがある。
    '③-②-②テーブルを使う場合
    Set DaoRs = DB.OpenRecordset("テーブル名", dbOpenTable)

    '③-③ワークシートに貼り付ける場合
    Dim FD As DAO.Field
    Dim Sh As Worksheet
    Dim RC, CC as long

    Set Sh = ActiveSheet

    '③-③-①SQLを使う場合
    RC = 1
    Do Until DaoRs.EOF
        CC = 1
        For Each FD In DaoRs.Fields
            If RC = 1 Then
                Sh.Cells(RC, CC).Value = FD.Name
            Else
                Sh.Cells(RC, CC).Value = FD.Value
            End If
            CC = CC + 1  '列番号
        Next
        RC = RC + 1      '行番号
        DaoRs.MoveNext
    Loop

    '③-③-②EXCELのCopyFromRecordsetを使う場合
    For Each FD In DaoRs.Fields
        Sh.Cells(1, CC).Value = FD.Name
        CC = CC + 1  '列番号
    Next
    Sh.Cells(2, 1).CopyFromRecordset DaoRs

    '③-④更新・追加・削除の場合
    'トランザクションの開始
    DBE.BeginTrans

    strSQL = "INSERT INTO テーブル名(列名1,列名2,列名3) VALUES('val',1,'2010/01/01');"
    strSQL = "UPDATE テーブル名 SET 列名2 = 10 WHERE 列名2 = 1;"
    strSQL = "DELETE テーブル名 WHERE 列名1 = 'val';"
    DB.Execute strSQL, dbFailOnError

　　'トランザクションをコミット
    If DB.RecordsAffected > 0 Then
        DBE.CommitTrans
    Else
    'ロールバックをかけて終了
        DBE.Rollback
    End If

    '③のエラー処理
ERROR_SHORI:
    If Not DaoRs Is Nothing Then DaoRs.Close
    Set DaoRs = Nothing
    If Not DB Is Nothing Then DB.Close
    Set DB = Nothing
    Set DBE = Nothing
End Sub

CSVにADOで接続

COPY

Private Sub ByAdoCSV()
    Dim AdoCn As ADODB.Connection
    Dim AdoRs As ADODB.Recordset
    Dim strSQL As String
On Error GoTo ERROR_SHORI

    Set AdoCn = New ADODB.Connection
    Set AdoRs = New ADODB.Recordset

    '④-①接続
    With AdoCn
　　    .Provider = "Microsoft.ACE.OLEDB.12.0"
　　    .Properties("Extended Properties") = "Text;HDR=Yes;FMT=Delimited"
　　    .Open "対象となるExcelファイルのパス" & "\"
    End With

　　'SQL文作成
　　strSQL = ""
　　strSQL = strSQL & " SELECT *"
　　strSQL = strSQL & " FROM"
　　strSQL = strSQL & " ファイル名;"

　　'④-②レコードセットの取得
    '④-②-①SQLの実行して、レコードセットの取得
    Set AdoRs = AdoCn.Execute(strSQL)
    '④-②-②または
    AdoRs.Open strSQL, AdoRs, _
               adOpenForwardOnly, adLockPessimistic, adCmdText
    '④-②-③次の表現も可
    With AdoRs
        .Source = strSQL
        .ActiveConnection = AdoCn
        .Open
    End With
    '④-②-④ファイル名を使う場合
    AdoRs.Open "ファイル名", AdoRs, _
               adOpenForwardOnly, adLockPessimistic, adCmdTable

    '④-③データを取得する場合
    Dim FD As Object
    Dim Sh As Worksheet
    Dim RC, CC As Long

    '④-③-①ワークシートに貼り付ける場合
    Set Sh = ActiveSheet

    '④-③-①-①SQLを使う場合
    RC = 1
    Do Until AdoRs.EOF
        CC = 1
        For Each FD In AdoRs.Fields
            If RC = 1 Then
                Sh.Cells(RC, CC).Value = FD.Name
            Else
                Sh.Cells(RC, CC).Value = FD.Value
            End If
            CC = CC + 1  '列番号
        Next
        RC = RC + 1      '行番号
        DaoRs.MoveNext
    Loop

    '④-③-①-②EXCELのCopyFromRecordsetを使う場合
    For Each FD In AdoRs.Fields
        Sh.Cells(1, CC).Value = FD.Name
        CC = CC + 1  '列番号
    Next
    Sh.Cells(2, 1).CopyFromRecordset AdoRs

    '④のエラー処理
ERROR_SHORI:
    略

AccessにADOで接続し、Findで検索後更新

COPY

Private Sub ByAdoAccessFind()
    Dim AdoCn As ADODB.Connection
    Dim AdoRs As ADODB.Recordset
    Dim strSQL As String
    Dim Criteria As String
    Dim iSkipRows As Long
    Dim iCount As Long
On Error GoTo ERROR_SHORI

    Set AdoCn = New ADODB.Connection
    Set AdoRs = New ADODB.Recordset

    AdoCn.ConnectionString = _
            "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=" & "対象となるAccessファイルのパスとファイル名"
    AdoCn.Open

    AdoRs.Open strSQL, AdoRs, _
               adOpenKeyset, adLockPessimistic, adCmdText
    'または
    AdoRs.Open "テーブル名", AdoRs, _
               adOpenKeyset, adLockOptimistic, adCmdTable
        
    Criteria = "フィールド名 Like '何何%'"

    iSkipRows = 0
    Do Until AdoRs.EOF
        '1つ目は，SkipRows引数を0にして実行し，以降は，SkipRows引数を1
        AdoRs.Find Criteria, iSkipRows, adSearchForward
            'Criteria の記述例
            'AdoRs.Find "クラス = '" & Str & "'"
            'AdoRs.Find "得点 > " &　Val
            'AdoRs.Find "入学日 = #" & Date & "#"
        If AdoRs.EOF = False Then
            'レコード処理を記述
            'AdoRs("商品名") = "商品名"
            'AdoRs("単価") = 数値
            'AdoRs.Update
            'または
            'AdoRs.Update Array("商品名","単価"), Array("商品名",数値)
            iCount = iCount + 1
        End If
        If iSkipRows = 0 Then iSkipRows = iSkipRows + 1 
    Loop
            
    If iCount = 0 Then
        MsgBox "該当するレコードはありません"
    Else
        MsgBox iCount & "件処理しました"
    End If

ERROR_SHORI:
    '略
End Sub

AccessにADOで接続しFilterで絞り込み後更新

COPY

Private Sub ByAdoAccessFind()
    Dim AdoCn As ADODB.Connection
    Dim AdoRs As ADODB.Recordset
    
    '略
    
    With AdoRs
        .Filter = "フィールド名1 = 3 AND フィールド名2 = '東京都'"
        If .EOF Or .BOF Then
            MsgBox "該当データがありません。"
            GoTo ERROR_SHORI
        Else
            .MoveFirst
            While Not .EOF
                .Fields("フィールド名3") = "文字列"
                .Fields("フィールド名4") = 数値
                .Update
                .MoveNext
            Wend
        End If
    End With
    
    '略
    
ERROR_SHORI:
    '略
End Sub

AccessにADOで接続しSeekで検索後更新

COPY

Private Sub ByAdoAccessFind()
    Dim AdoCn As ADODB.Connection
    Dim AdoRs As ADODB.Recordset
    
    '略

    DAT = Str
    RS.Index = "フィールド名1"
    RS.Seek DAT, adSeekFirstEQ
    
    With AdoRs
        If .EOF Then
            MsgBox "該当データがありません。"
        Else
            .Fields("フィールド名2") = "文字列"
            .Fields("フィールド名3") = 数値
            .Update
    End If

    '略
    
ERROR_SHORI:

    '略

End Sub

AccessにDAOで接続しFindで検索後更新

COPY

Private Sub byDaoAccessFind()
    Dim DBE As DAO.DBEngine     'DAOのエンジン本体
    Dim DB As DAO.Database      'データベースオブジェクト
    Dim DaoRs As DAO.Recordset

    '略

    With DaoRs
        If .EOF Or .BOF Then
            MsgBox "該当データがありません。"
            GoTo ERROR_SHORI
        Else
            .FindFirst "フィールド名1 = 3 AND フィールド名2 = '東京都'"
            While Not .NoMatch
                .Edit
                .Fields("フィールド名2") = "文字列"
                .Fields("フィールド名3") = 数値
                .Update
                .FindNext "フィールド名1 = 3 AND フィールド名2 = '東京都'"
            Wend
        End If
    End With
    MsgBox "処理を終了しました。", vbOKOnly + vbInformation

    '略
        
ERROR_SHORI:

    '略

End Sub