AccessからExcelを起動して、
新規のブック、シートに データを(クエリーの中身を)書き込みます。
ADOでクエリーを読み込み、Excelへ単純に書き出す
クエリーからエクセルへデータを転記します。
書き込み後、
エ．で調べた、列幅の自動調整の命令
Cells.EntireColumn.AutoFit
を使用して、列幅を自動調整してみます。
Private Sub btest001_Click() 'クエリー QDATA を Excelのシートに書き込む Dim rs As New ADODB.Recordset 'ADOのレコードセット Dim objEXCEL As Object 'Excel参照用 'Excelを起動する Set objEXCEL = CreateObject("Excel.Application") 'オブジェクトの作成 objEXCEL.Visible = True 'Excelを見えるようにする objEXCEL.Workbooks.Add 'Excelのブックを新規に作成(追加) 'Excelのシートを追加、シート名を氏名に変更する objEXCEL.Sheets.Add 'シートを追加する 'レコードセットを開く(QDATA) rs.Open "QDATA", CurrentProject.Connection, _ adOpenKeyset, adLockOptimistic '見出しを書き込む objEXCEL.Range("A1") = "ドラマタイトル" objEXCEL.Range("B1") = "出演者" objEXCEL.Range("C1") = "役名" Dim yLINE As Integer '行カウンター 'ループ処理 レコードが無くなるまで書き込む yLINE = 2 '２行目から書き込みたいので、行カウンターを２にする While rs.EOF = False 'いつものEOFが偽の間 'データをセットする(Accessから転記) objEXCEL.Cells(yLINE, "A") = rs.Fields("ドラマタイトル") objEXCEL.Cells(yLINE, "B") = rs.Fields("出演者") objEXCEL.Cells(yLINE, "C") = rs.Fields("役名") rs.MoveNext '次のレコードに移動しないと、とんでもないことに(笑) yLINE = yLINE + 1 'セット位置も次に移動(+1で一つ下) Wend 'Excelシートの列幅を自動調整 objEXCEL.Cells.EntireColumn.AutoFit '通常は、ここでExcelを保存するんだけど、今回は開きっぱなしの手抜き rs.Close '開いたら閉じろ、ドアを開けたら閉めるってしつけられたでしょ(笑) Set rs = Nothing '変数も後始末しますか。使った器はキレイにしろって? End Sub
↑データ出力のループが終了したら、
'Excelシートの列幅を自動調整
objEXCEL.Cells.EntireColumn.AutoFit
を１行入れただけです。
グループ単位(ドラマタイトル単位)でシートを作成して書き込む
クエリーからデータを読み込み、
ドラマのタイトルが変わったら、シートを新しく作成して、
シート単位でデータを作成してみました。
作成後、全てのシートに対して
.Cells.EntireColumn.AutoFit
をかけて、列幅を調整してみました。
Private Sub btest002_Click() 'シート単位でデータを書き込む Dim rs As New ADODB.Recordset 'ADOのレコードセット Dim objEXCEL As Object 'Excel参照用 'Excelを起動する Set objEXCEL = CreateObject("Excel.Application") 'オブジェクトの作成 objEXCEL.Visible = True 'Excelを見えるようにする objEXCEL.Workbooks.Add 'Excelのブックを新規に作成(追加) 'レコードセットを開く(QDATA) rs.Open "QDATA", CurrentProject.Connection, _ adOpenKeyset, adLockOptimistic Dim yLINE As Integer '行カウンター Dim strOLDTITLE As String '前回行のタイトル strOLDTITLE = "XXX前回のタイトル" '初めに違うタイトルとしたいので 'ループ処理 レコードが無くなるまで書き込む While rs.EOF = False 'いつものEOFが偽の間 'タイトルが変更されたタイミングで新規シートを作る If strOLDTITLE <> rs.Fields("ドラマタイトル") Then 'タイトルが変わったら 'Excelのシートを追加、シート名をドラマタイトルに変更する objEXCEL.Sheets.Add 'シートを追加する objEXCEL.ActiveSheet.Name = rs.Fields("ドラマタイトル") 'シート名をドラマタイトルにする '見出しを書き込む objEXCEL.Range("A1") = "ドラマタイトル" objEXCEL.Range("B1") = "出演者" objEXCEL.Range("C1") = "役名" strOLDTITLE = rs.Fields("ドラマタイトル") 'ドラマのタイトルを覚える、保存する yLINE = 2 '２行目から書き込みたいので、行カウンターを２にする End If 'データをセットする(Accessから転記) objEXCEL.Cells(yLINE, "A") = rs.Fields("ドラマタイトル") objEXCEL.Cells(yLINE, "B") = rs.Fields("出演者") objEXCEL.Cells(yLINE, "C") = rs.Fields("役名") rs.MoveNext '次のレコードに移動しないと、とんでもないことに(笑) yLINE = yLINE + 1 'セット位置も次に移動(+1で一つ下) Wend 'データ書き込み完了後、ループで全てのシートに対して、列幅を自動調整 Dim n As Integer 'シートのカウンター For n = 1 To objEXCEL.Sheets.Count 'シートの数だけ回す objEXCEL.Sheets(n).Select 'n番目のシートを選択 objEXCEL.Cells.EntireColumn.AutoFit '列幅を自動調整する Next objEXCEL.Sheets(1).Select '一番左のシートを選択する '通常は、ここでExcelを保存するんだけど、今回は開きっぱなしの手抜き rs.Close '開いたら閉じろ、ドアを開けたら閉めるってしつけられたでしょ(笑) Set rs = Nothing '変数も後始末しますか。使った器はキレイにしろって? End Sub
ここでは、データ転記終了後、
'データ書き込み完了後、ループで全てのシートに対して、列幅を自動調整
Dim n As Integer 'シートのカウンター
For n = 1 To objEXCEL.Sheets.Count 'シートの数だけ回す
objEXCEL.Sheets(n).Select 'n番目のシートを選択
objEXCEL.Cells.EntireColumn.AutoFit '列幅を自動調整する
Next
objEXCEL.Sheets(1).Select '一番左のシートを選択する
で、全てのシートに対して、列幅を自動調整してみました。
※本当は、シートを作りながら１枚１枚調整したかったけど、、、
↓そんな処理でハマった話は、下記の解説動画を見て笑ってください。
操作動画と解説
下記、いつもの動画解説です。※けっこうハマってしまった・・無編集なので30分近くウダウダやってます(ぉぃぉぃ)
www.youtube.com
http://www.youtube.com/watch?v=_ltba_DuW6o
↑YouTubeに15分以上の動画をUP可能になったので、
調子に乗ってノーカットで、アップしてしまった
※やはり、最低限の編集は必要だったなぁ・・・と思いつつ、15分以上の実験を兼ねてアップしました。
全体の流れ／解説は http://ken3hitori.g.hatena.ne.jp/bbs/18?from=1 を見てください。
