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))
このプログラムでデータを貼り付けると[元に戻す]ボタンを使っても貼り付ける前には戻らないので注意が必要。
コメント