三流君 ken3のmemo置き場

三流プログラマーのメモ書きです。主にVBAやWindowsの話題が多いです

挨拶・自己紹介:
失敗続きのAB型の変わり者 :三流プログラマー Ken3です
フリーのエンジニア・個人事業主です・・と書くと聞こえはイイが(それとなくカッコよく聞こえるが)、 現在は小さな案件の受注請負 と 短期派遣 で 日々つつましく?ほそぼそと暮らしてます。
よく検索されるキーワード: [質問回答XXXXさんへ] [CreateObject] [VBA] [JRA競馬オッズ]

QA110203 ア.AccessのクエリーをExcelに書き出す 転記する

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  '2行目から書き込みたいので、行カウンターを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
を1行入れただけです。

グループ単位(ドラマタイトル単位)でシートを作成して書き込む

クエリーからデータを読み込み、
ドラマのタイトルが変わったら、シートを新しく作成して、
シート単位でデータを作成してみました。

作成後、全てのシートに対して
.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  '2行目から書き込みたいので、行カウンターを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 '一番左のシートを選択する

で、全てのシートに対して、列幅を自動調整してみました。
※本当は、シートを作りながら1枚1枚調整したかったけど、、、
↓そんな処理でハマった話は、下記の解説動画を見て笑ってください。

操作動画と解説

下記、いつもの動画解説です。※けっこうハマってしまった・・無編集なので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 を見てください。

Ken3 ホームページ 目次

分類:HPを大きく分けると4つの柱(分類)です。
・[Excel/Access VBA]の解説
・[ASP(Active Server Pages)]の解説。
・[元コンビニ店長時代の話]が弟に巻き込まれ、失敗した脱サラ、畑違い?の仕事で失敗。
・[プログラマーの愚痴]では、あまり見せたくない三流プログラマーの内面かな。
三流君を踏み台にする
主に上記4つの分類でHP作成やメルマガの発行を行ってます。
※更新頻度が落ちていて情報の鮮度が悪いです。



Googleを使用して検索する

読者の声:三流君の説明・解説じゃ よくわからなかったから、Googleを使って、自分で検索します。
三流君:残念です。あっ、下記にGoogleの検索窓を設置しました。
いろいろ指定して試してみてください。

Google
探す言葉:気になる単語や,オブジェクト(Document),プロパティ(.Busy)やメソッド(.Navigate)などを入れて検索してみてください。


言語を指定:見つからない時は指定無しで探す

サイト指定:人気QAサイト や 一次情報MS本家を指定する
一次情報・二次情報まとめから探る
QAサイトの質問から探る
検索実行: ←オプション確認後に検索ボタンを押してください

期間指定:情報の鮮度も大切?
検索実行: ←オプション確認後に検索ボタンを押してください


本当に三流なんです(笑):たまにスゴイですねなんて言われることもありますが、
真実は→ [三流君の真実は...] ←を初めに見てくださるとわかると思います。
(からくりは、成功例↑しか載せてなくて ヒドイ失敗例はお蔵入り迷宮入りが多かったりします)