VBAでデータベースからの作表・印刷処理を自動化する 1

Excel VBAでさまざまな表印刷を行う－コード編

更新日: 2008/08/19
公開日: 2007/05/08

ポスト

ダウンロードバイナリファイル (87.9 KB)
ダウンロードサンプルソース (137.9 KB)

コードバージョンの印刷自動処理－データベース操作－リスト1

　最初に、コードで印刷処理を自動化するバージョンを作成します。

　まずは、データベースへのアクセスとクエリの実行を行うプロシージャを、標準モジュール「Module2」に作成します。このプロシージャは、テーブルに対し1つのクエリを実行します。実行結果は、そのままワークシートSheet1のセルに転送します。

　このとき、クエリの結果が全部で何件あるのかを返すように、Functionプロシージャで作成します。これは、このプロシージャを呼び出すメインの処理の中で、セルの列幅の合計を算出する処理などに使用するためです。プロジェクトに2つの標準モジュールを挿入し、DAOへの参照設定を行います。付録に収録してあるデータベースファイルは、Access 2000で作成しているため、DAO 3.6への参照設定を行なってください。

作成するFunctionプロシージャ「DBAccess」は、2つの引数を持たせています。1つは、クエリを実行するSQL文字列で、もう1つは取得するフィールド数です。プロシージャの戻り値は、Integer型です。この戻り値が、クエリ結果の総レコード数で、作表時の行数になります。

Function DBAccess(ByVal SQLstring As String, _
                  FieldNum As Integer) As Integer

データベースファイルにアクセスし、テーブルを開きます。ここでは、マクロを作成するブックと同じフォルダに「msdata.mdb」というファイルを配置し、この中にある「MSデータ」というテーブルを開きます。

DBFile = ThisWorkbook.Path & "\msdata.mdb"
Set NewDB = DBEngine.OpenDatabase(DBFile)
Set Tbl = NewDB.OpenRecordset("MSデータ")

そして、設定されているフィールド名をセルに転送します。その数は、プロシージャの引数「FieldNum」に設定される値を使用します。これで、プロシージャ実行時に必要なフィールド数を選べるようにします。

For i = 1 To FieldNum
    Cells(1, i) = Tbl.Fields(i).Name
Next

CreateQueryDefメソッドを使用して、クエリを実行します。使用するクエリ用SQL文字列は、プロシージャの引数「SQLstring」から受け取るようにします。

Set Newq = NewDB.CreateQueryDef("", SQLstring)
Set QResult = Newq.OpenRecordset()

CreateQueryDefメソッドを実行したら、OpenRecordsetメソッドでクエリテーブルを開きます。そして、RecordCountプロパティを参照し抽出されたレコードがあるかどうかをチェックします。クエリ結果が無ければ、メッセージボックスを表示しプロシージャの戻り値に0をセットし、データベースの終了処理にジャンプします。

If QResult.RecordCount = 0 Then
    MsgBox "抽出データはありません"
    DBAccess = 0
    GoTo FAIL
End If

クエリに成功したら、そして、MoveLastメソッドでカレントレコードを一旦最終レコード位置に移動し、レコードの総数を取得しプロシージャの戻り値に設定しておきます。Functionプロシージャの戻り値を設定するには、プロシージャと同名の変数に値を代入します。

QResult.MoveLast
RCount = QResult.RecordCount

DBAccess = RCount

レコード数が把握できたら、カレントレコード位置をクエリテーブルの先頭に移動し、フィールドデータを1つづつセルに転送します。ここでは、2つのFor...NextループとMoveNextメソッドを使い、フィールドの移動とレコード位置の移動を自動化しています。

QResult.MoveFirst
For i = 2 To RCount
    For j = 1 To FieldNum
        Cells(i, j) = QResult.Fields(j).Value
    Next
    QResult.MoveNext
Next

これで、クエリ結果のデータ転送が完了です。各テーブルを閉じて使用したオブジェクト変数を開放して終了です。先ほどのGoToステートメントの移動先ラベルは、ここに設定しておきます。

FAIL:
    Newq.Close
    QResult.Close
    Tbl.Close
    NewDB.Close

    Set Newq = Nothing
    Set QResult = Nothing
    Set Tbl = Nothing
    Set NewDB = Nothing

End Function

リスト1

Function DBAccess(ByVal SQLstring As String, FieldNum As Integer) _
    As Integer
    Dim NewDB As Database
    Dim Tbl As Recordset
    Dim Newq As QueryDef
    Dim DBFile As String
    Dim RCount As Long
    Dim QResult As Recordset
    Dim i As Integer, j As Integer

    DBFile = ThisWorkbook.Path & "\msdata.mdb"
    Set NewDB = DBEngine.OpenDatabase(DBFile)
    Set Tbl = NewDB.OpenRecordset("MSデータ")

    For i = 1 To FieldNum
        Cells(1, i) = Tbl.Fields(i).Name
    Next

    Set Newq = NewDB.CreateQueryDef("", SQLstring)

    Set QResult = Newq.OpenRecordset()
     If QResult.RecordCount = 0 Then
        MsgBox "抽出データはありません"
        DBAccess = 0
        GoTo FAIL
    End If

    QResult.MoveLast
    RCount = QResult.RecordCount

    DBAccess = RCount

    QResult.MoveFirst
    For i = 2 To RCount
        For j = 1 To FieldNum
            Cells(i, j) = QResult.Fields(j).Value
        Next
        QResult.MoveNext
    Next

FAIL:
    Newq.Close
    QResult.Close
    Tbl.Close
    NewDB.Close

    Set Newq = Nothing
    Set QResult = Nothing
    Set Tbl = Nothing
    Set NewDB = Nothing

End Function

メインの印刷処理の作成－リスト2

　処理のメインとなる、データによって用紙を変えて印刷するプロシージャを標準モジュール「Module1」に作成します。このプロシージャが、マクロ用プロシージャになります。

　なお、データベース処理用プロシージャと標準モジュールを分けたのは単にプロシージャの場所を分かりやすくしたためで、特別な意味はありません。

最初に、前回のクエリ結果がセルにあれば、そのセルデータを消去しておきます。RangeオブジェクトのCellsメソッドを引数なしで指定すると、ワークシートのすべてのセルを操作対象にできます。そして、Selectメソッドで選択しRangeオブジェクトのClearメソッドを実行すれば、罫線も含めすべてのセル情報を消去できます。

Worksheets("Sheet1").Cells.Select
Selection.Clear
Range("A1").Select

変数SQLstringに、クエリを実行するSQL文字列を格納します。また、変数ColumnNoに操作対象のフィールド数を設定し、先ほど作成したデータベース処理のFunctionプロシージャDBAccessを、これらを引数に設定して実行します。

プロシージャDBAccessの戻り値（クエリ結果のレコード数）は変数RowNoに格納し、クエリ結果がなければ、ここで処理を中止します。

'SQLstring = "Select * from MSデータ _
'    Where MSデータ.所属 = 'エゥーゴ'"
SQLstring = "Select * from MSデータ "

ColumnNo = 4
RowNo = Module2.DBAccess(SQLstring, ColumnNo)

If RowNo = 0 Then
    MsgBox "クエリ結果のデータがないため処理を終了します"
    Exit Sub
End If

クエリ結果が1つでもあれば、作表処理を開始します。

まず、InputBox関数でインプットボックスを表示し、表のタイトルを入力してもらいます。次に、入力データのあるセルの幅を、データのサイズに合わせるためAutoFitメソッドを実行します。

なお、このメソッドは、操作対象に列または行を指定します。セル番地ではありませんので注意してください。EntireColumnプロパティは、セル範囲の中の列だけをオブジェクトとして返すプロパティです。このプロパティを操作対象にAutoFitメソッドを実行すると、各列幅がセルに入力されているデータの最大長に合わせられます。

続いて、罫線を設定するかどうかをメッセージボックスで問い合わせ、［はい］ボタンが押された時のみ罫線を設定します。この罫線設定処理は、独自のSubプロシージャで作成し、これを呼び出す形にします。

Title = InputBox("表のタイトルを入力してください")

Range(Cells(1, 1), Cells(1, ColumnNo)).Select
Selection.EntireColumn.AutoFit
Ret = MsgBox("作成する表に罫線を入れますか", vbYesNo)
If Ret = vbYes Then
    Call 罫線設定(RowNo, ColumnNo)
End If

今度は、各列の列幅を合計します。RangeオブジェクトのWidthプロパティは、セルの列幅を格納しているプロパティで、単位はポイントです。これを、データのある列数分加算します。

1ポイントは約0.35mmなので、合計した列幅にこれをかけて10で割り、センチメートルに換算します。計算結果は小数点になっているため、Round関数を使用して整数になるよう四捨五入します（用紙操作をミリ単位で行いたい場合は、これらの数値をミリに換算しなおして使用します）。

For i = 1 To ColumnNo
    Ttl = Ttl + Cells(1, i).Width
Next

Ttl = Round(Ttl * 0.35) / 10

ワンポイント・アドバイス

　この数値は、ワークシートに設定しているフォントの種類とサイズによって違ってきます。フォントサイズが大きければ長く、小さければ短くなります。

これで、セルに入力されたデータの横方向の長さが出ました。これを使って、A4の用紙のサイズと比較します。この処理は、Select Caseステートメントを使い、全部で5つの処理に振り分けます。

用紙設定は、最初はA4縦で左右の余白を2cmずつ取っているため、実際にセルが印刷される範囲は（21-4）で17cmです。これ以内に収まっていれば、そのまま用紙を縦方向で印刷します。

17cmを超えてしまうのであれば、左右の余白を1cmに減らして収まるかどうかを判断します。この値に入れば、左右の余白を設定し直して用紙を縦方向で印刷します。

それでもダメなら、今度は用紙を横にして印刷します。横方向の場合は用紙の幅が約30cmになります。これも最初は左右の余白を2cmとりますので、（30-4）で26cmが印刷できる範囲になります。

従って、セルの列幅の合計が20cmを超え26cm以内であれば、左右の余白2cmで用紙を横方向に切り替えて印刷します。

それでも入らなければ左右余白を1cm減らし、27cmから28cmの間で印刷可能かどうかをチェックします。

これでもダメなら、左右方向が1ページに収まるようなページ設定を行い印刷します。

これらの処理は、独自のSubプロシージャを作成して呼び出す形にします。このプロシージャは、用紙の方向、左右余白値、表のタイトルを引数に持たせ、設定を変えて実行できるようにしています。

Select Case Ttl
    Case Is < 17
        Call PrintSet("A4縦", 2, Title)
    Case 17 To 19
        Call PrintSet("A4縦", 1, Title)  '左右のマージンで調整
    Case 20 To 26
        Call PrintSet("A4横", 2, Title)
    Case 27 To 28
        Call PrintSet("A4横", 1, Title)
    Case Is > 28
        Call FitPage(Title)         'データを用紙に収めて印刷する
End Select

用紙設定が済んだら印刷を開始します。これは、WorksheetオブジェクトのPrintOutメソッドを使用します。

    '印刷開始
    With Worksheets("Sheet1")
        .Range("A1").Select
        .PrintOut  '必要に応じて部数を指定
    End With
End Sub

リスト2

Sub 用紙切り替え()
    Dim SQLstring As String
    Dim RowNo As Integer, ColumnNo As Integer
    Dim Ret As Integer
    Dim Ttl As Single
    Dim Title As String

    '前回のセルデータを消去
    Worksheets("Sheet1").Cells.Select
    Selection.Clear
    Range("A1").Select

    'データベースを開きクエリを実行する
    'SQLstring = "Select * from MSデータ _
    '    Where MSデータ.所属 = 'エゥーゴ'"
    SQLstring = "Select * from MSデータ "

    ColumnNo = 4
    RowNo = Module2.DBAccess(SQLstring, ColumnNo)

    If RowNo = 0 Then
        MsgBox "クエリ結果のデータがないため処理を終了します"
        Exit Sub
    End If

    '表のタイトルと罫線設定の有無を聞く
    Title = InputBox("表のタイトルを入力してください")

    'オートフィットを実行
    Range(Cells(1, 1), Cells(1, ColumnNo)).Select
    Selection.EntireColumn.AutoFit

    Ret = MsgBox("作成する表に罫線を入れますか", vbYesNo)
    If Ret = vbYes Then
        Call 罫線設定(RowNo, ColumnNo)
    End If

    For i = 1 To ColumnNo
        Ttl = Ttl + Cells(1, i).Width
    Next

    Ttl = Round(Ttl * 0.35) / 10

    'A4縦の横幅は約21cm、用紙が横の場合は約30cm
    Select Case Ttl
        Case Is < 17
            Call PrintSet("A4縦", 2, Title)
        Case 17 To 19
            Call PrintSet("A4縦", 1, Title)  '左右のマージンで調整
        Case 20 To 26
            Call PrintSet("A4横", 2, Title)
        Case 27 To 28
            Call PrintSet("A4横", 1, Title)
        Case Is > 28
            Call FitPage(Title)         'データを用紙に収めて印刷する
    End Select

    '印刷開始
    With Worksheets("Sheet1")
        .Range("A1").Select
        '.PrintOut  '必要に応じて部数を指定
    End With
End Sub

次のページ
用紙切り替え処理－リスト3

この記事は参考になりましたか？

印刷用を表示

ポスト

Excel VBAでさまざまな表印刷を行う連載記事一覧: VBAでデータベースからの作表・印刷処理を自動化する 2

VBAでデータベースからの作表・印刷処理を自動化する 1

この記事の著者: 瀬戸遥（セトハルカ）

8ビットコンピュータの時代からBASICを使い、C言語を独習で学びWindows 3.1のフリーソフトを作成、NiftyServeのフォーラムなどで配布。Excel VBAとVisual Basic関連の解説書を中心に現在まで40冊以上の書籍を出版。近著に、「ExcelユーザーのためのAccess再...

※プロフィールは、執筆時点、または直近の記事の寄稿時点での内容です

この著者の最近の執筆記事