Excel

ExcelのVBAからADOを利用してAccessのテーブルやクエリー(SQL文含む)、で取得したレコードセットをアクティブセルに貼り付けるサンプルプログラム。

今回のサンプルプログラムではCopyFromRecordsetメソッドは使用せずに、セルに1つ1つデータを書き込む方法を用いている。

以下にサンプルプログラムを記述。
スポンサードリンク


VBAサンプルプログラム1

接続するデータベースは、Accessに添付されているサンプルデータベース"Northwind.mdb"を使用している。

セルにデータを書き込む際に、表示形式の設定やデータそのものの加工をして書き込んでいる。
Sub Sample01()
Dim Con As Object, Rec As Object
Dim FieldCounter As Integer, i As Integer, j As Integer
Dim Rng As Range, targetRng As Range, Ans As Integer

'処理中の画面描画を停止
Application.ScreenUpdating = False

Set Con = CreateObject("ADODB.Connection")
    With Con
         .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" _
                            & "C:\Program Files\Microsoft Office\Office\Samples\Northwind.mdb;" _
                            & "Persist Security Info=False"
        .Open
    End With
   
 Set Rec = CreateObject("ADODB.Recordset")
    'テーブル名、クエリー名、SQL文のいずれかを指定しレコードセットを開く
    Rec.Open "社員", Con
        
    'フィールド名が必要ない場合は、以下の3行は削除
    For i = 0 To Rec.Fields.Count - 1
        ActiveCell.Offset(0, i) = Rec.Fields(i).Name
    Next i
    
    j = 1 '上記3行のフィールド名の書き込み部分を削除した場合は、J = 0 に変更
    Do Until Rec.EOF
        For i = 0 To Rec.Fields.Count - 1
            'フィールドによって異なる処理を行うことが多い場合は「Select Case」を使う
            '誕生日、入社日が書き込まれるセルの表示形式を変更
            If Rec.Fields(i).Name = "誕生日" Or Rec.Fields(i).Name = "入社日" Then
                ActiveCell.Offset(j, i).NumberFormatLocal = "yyyy/mm/dd"
                ActiveCell.Offset(j, i).Value = Rec(i)
            '郵便番号らしく「〒XXX-XXXX」にするためにデータを加工
            ElseIf Rec.Fields(i).Name = "自宅郵便番号" Then
                ActiveCell.Offset(j, i).Value = "〒" & Mid(Rec(i), 1, 3) & "-" & Mid(Rec(i), 4, 4)
            Else
                ActiveCell.Offset(j, i).Value = Rec(i)
            End If
        Next i
        Rec.MoveNext
        j = j + 1
    Loop
    
End Sub

VBAサンプルプログラム2

貼り付け範囲に別のデータが入っていた場合に上書きしてかまわないかどうかを確認するメッセージを表示し、[いいえ]が選択されたら処理を中止するコードを追加。

貼り付けるレコード数が多い場合は、チェックに時間がかかる点に注意。
Sub Sample02()
Dim Con As Object, Rec As Object
Dim FieldCounter As Integer, i As Integer, j As Integer
Dim Rng As Range, targetRng As Range, Ans As Integer

'処理中の画面描画を停止
Application.ScreenUpdating = False

Set Con = CreateObject("ADODB.Connection")
    With Con
         .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" _
                            & "C:\Program Files\Microsoft Office\Office\Samples\Northwind.mdb;" _
                            & "Persist Security Info=False"
        .CursorLocation = 3 'adUseClient
        .Open
    End With
    
 Set Rec = CreateObject("ADODB.Recordset")
    Rec.Open "SELECT * From 社員 Where 部署名='第一営業'", Con
    
    'レコードを貼り付ける範囲に別のデータが入っていた場合は上書きするかどうか確認する
    FieldCounter = Rec.Fields.Count
        With ActiveCell
            Set targetRng = Range(Cells(.Row, .Column), _
                        Cells(.Offset(Rec.RecordCount - 1, 0).Row, _
                        .Offset(0, FieldCounter - 1).Column))
            
            'レコード貼り付け範囲に別のデータがないか確認する
            For Each Rng In targetRng
                If Rng.Value <> "" Then
                    Ans = MsgBox("貼り付け範囲にデータが入力されています。" + vbCrLf + _
                                "処理を中止しますか?", vbYesNo + vbExclamation)
                    If Ans = vbYes Then
                        Exit Sub
                    Else
                        Exit For
                    End If
                End If
            Next Rng
        End With
    
    'フィールド名が必要ない場合は、以下の3行は削除
    For i = 0 To FieldCounter - 1
        ActiveCell.Offset(0, i) = Rec.Fields(i).Name
    Next i
    
    j = 1 '上記3行のフィールド名の書き込み部分を削除した場合は、J = 0 に変更
    Do Until Rec.EOF
        For i = 0 To FieldCounter - 1
            'フィールドによって異なる処理を行うことが多い場合は「Select Case」を使う
            '誕生日、入社日が書き込まれるセルの表示形式を変更
            If Rec.Fields(i).Name = "誕生日" Or Rec.Fields(i).Name = "入社日" Then
                ActiveCell.Offset(j, i).NumberFormatLocal = "yyyy/mm/dd"
                ActiveCell.Offset(j, i).Value = Rec(i)
            '郵便番号らしく「〒XXX-XXXX」にするためにデータを加工
            ElseIf Rec.Fields(i).Name = "自宅郵便番号" Then
                ActiveCell.Offset(j, i).Value = "〒" & Mid(Rec(i), 1, 3) & "-" & Mid(Rec(i), 4, 4)
            Else
                ActiveCell.Offset(j, i).Value = Rec(i)
            End If
        Next i
        Rec.MoveNext
        j = j + 1
    Loop
    
End Sub

フィールド名を除外したい場合

貼り付け範囲はフィールド名も含めた範囲が指定されているので、フィールド名を省いて貼り付ける場合は、24~26行目を以下のように変更する。
            Set targetRng = Range(Cells(.Row, .Column), _
                            Cells(.Offset(Rec.RecordCount - 1, 0).Row, _
                            .Offset(0, FieldCounter - 1).Column))
このプログラムでデータを貼り付けると[元に戻す]ボタンを使っても貼り付ける前には戻らないので注意が必要。

スポンサードリンク

  

関連記事