http://d.hatena.ne.jp/ken3memo/20091124/1258994342 からの続きです。
5.4 データの転記 ひな型(テンプレート)にデータを流し込みます
やっと、データの転記処理です。
5.4.1 ファイルの位置をCurrentDb.Nameから抜き出す
と、その前に、oApp.Workbooks.Open Filename:="E:\WORK\テンプレート.xls"
だと、E:\WORK\とフォルダー・ディレクトリの場所が固定なので、
手前味噌の No.007 MDBと同フォルダのExcelファイルを開く
http://www.ken3.org/vba/backno/vba007.html
を参考にして、
Private Sub コマンド0_Click() On Error GoTo Err_コマンド0_Click Dim oApp As Object 'Excelアプリの参照用 Dim strWORK As String '文字編集用のワーク変数 Dim i As Integer Dim strMDBPATH As String 'MDBの保存場所、フォルダー・ディレクトリ Dim strXLSFILE As String 'テンプレートファイルの名前、e:\xxx\yyyy\テンプレート.xls 'Accessの起動位置を取得 CurrentDb.NameにD:\xxxx\yyyy\zzz.mdbが入っている strWORK = CurrentDb.Name '後ろから1文字単位で¥を探す For i = Len(strWORK) To 1 Step -1 If Mid(strWORK, i, 1) = "\" Then Exit For '¥だったら抜ける Next i 'D:\xxxx\yyyy\zzz.mdb --> D:\xxxx\yyyy\ にする strMDBPATH = Mid(strWORK, 1, i) 'Excelの元ファイルの名前を作成 D:\xxxx\yyyy\ + テンプレート.xls strXLSFILE = strMDBPATH & "テンプレート.xls" 'ファイルの存在をチェックする If Dir(strXLSFILE) = "" Then MsgBox strXLSFILE & " の存在を 確認して下さい" Exit Sub 'エラーなので途中で抜ける End If Set oApp = CreateObject("Excel.Application") oApp.Visible = True 'Only XL 97 supports UserControl Property On Error Resume Next oApp.UserControl = True 'テンプレートファイルを開く oApp.Workbooks.Open Filename:=strXLSFILE Exit_コマンド0_Click: Exit Sub Err_コマンド0_Click: MsgBox Err.Description Resume Exit_コマンド0_Click End Sub
CurrentDb.Name から 現在のフルパスを取り、パスを抜き出して、"テンプレート.xls"と合わせてみました。
strXLSFILEが無事に作成されたら、
おまけで、Dir関数を使用して、ファイルの存在チェックも行い、
oApp.Workbooks.Open Filename:=strXLSFILE
で、開きました。
5.4.2 社員テーブルから全てのデータを抜き出しセットする
手前味噌のNo.093 Access2000 ADOでクエリーのレコードを参照 Excelへ出力
http://www.ken3.org/vba/backno/vba093.html
を参考にして、データをセットしてみます。
Dim rs As New ADODB.Recordset
で変数を1つ作成して、
rs.Open "select * from 社員テーブル;", CurrentProject.Connection, _
adOpenKeyset, adLockOptimistic
で、レコードセットを作ります(開きます)
あとは、.EOFのループで
'ループ処理
While rs.EOF = False 'いつものEOFが偽の間
MsgBox "氏名は" & rs.Fields("氏名") '氏名をテストで表示する
rs.MoveNext '次のレコードに移動しないと、とんでもないことに(笑)
Wend
rs.Fields("フィールド名")で、データを取り出せるので、
oApp.cells(行, 列) = rs.Fields("氏名")
みたいな感じで、セットします。
www.youtube.com
http://www.youtube.com/watch?v=Bs-J-51DEt0
[動画を貼る]
↓データセットまでのソース
Option Compare Database Option Explicit Private Sub コマンド0_Click() On Error GoTo Err_コマンド0_Click Dim oApp As Object 'Excelアプリの参照用 Dim strWORK As String '文字編集用のワーク変数 Dim i As Integer Dim strMDBPATH As String 'MDBの保存場所、フォルダー・ディレクトリ Dim strXLSFILE As String 'テンプレートファイルの名前、e:\xxx\yyyy\テンプレート.xls 'Accessの起動位置を取得 CurrentDb.NameにD:\xxxx\yyyy\zzz.mdbが入っている strWORK = CurrentDb.Name '後ろから1文字単位で¥を探す For i = Len(strWORK) To 1 Step -1 If Mid(strWORK, i, 1) = "\" Then Exit For '¥だったら抜ける Next i 'D:\xxxx\yyyy\zzz.mdb --> D:\xxxx\yyyy\ にする strMDBPATH = Mid(strWORK, 1, i) 'Excelの元ファイルの名前を作成 D:\xxxx\yyyy\ + テンプレート.xls strXLSFILE = strMDBPATH & "テンプレート.xls" 'ファイルの存在をチェックする If Dir(strXLSFILE) = "" Then MsgBox strXLSFILE & " の存在を 確認して下さい" Exit Sub 'エラーなので途中で抜ける End If Set oApp = CreateObject("Excel.Application") oApp.Visible = True 'Only XL 97 supports UserControl Property On Error Resume Next oApp.UserControl = True 'テンプレートファイルを開く oApp.Workbooks.Open Filename:=strXLSFILE Dim rs As New ADODB.Recordset 'ADOのレコードセットです。 Dim y As Integer 'セットする行番号です rs.Open "select * from 社員テーブル;", CurrentProject.Connection, _ adOpenKeyset, adLockOptimistic 'ループ処理 y = 4 '4行目からセットします。 While rs.EOF = False 'いつものEOFが偽の間 oApp.cells(y, "A") = rs.Fields("社員番号") 'データをExcelへセットする。 oApp.cells(y, "B") = rs.Fields("氏名") oApp.cells(y + 1, "B") = rs.Fields("ふりがな") '※2段目なのでy+1 oApp.cells(y, "C") = rs.Fields("生年月日") oApp.cells(y + 1, "C") = rs.Fields("性別") oApp.cells(y, "D") = rs.Fields("郵便番号") & " " & rs.Fields("住所") oApp.cells(y, "E") = rs.Fields("電話番号") oApp.cells(y + 1, "E") = rs.Fields("本籍") oApp.cells(y, "F") = rs.Fields("配偶者有無") oApp.cells(y, "G") = rs.Fields("雇用年月日") 'H列に持っている資格複数をセットする。※後で作成する。 rs.MoveNext '次のレコードに移動しないと、とんでもないことに(笑) y = y + 2 '1つの名簿データで2行使うので、+2で次の行です Wend rs.Close '開いたら閉じろ、ドアを開けたら閉めるってしつけられたでしょ(笑) Set rs = Nothing '変数も後始末しますか。使った器はキレイにしろって? Exit_コマンド0_Click: Exit Sub Err_コマンド0_Click: MsgBox Err.Description Resume Exit_コマンド0_Click End Sub
続きは http://d.hatena.ne.jp/ken3memo/20091124/1259006845 を見てください。