www.smiyasaka.com  は、2019 年2月から SSL 化し 通信を暗号化した方式で発信をしています。

● Excel マクロの解説 「 印刷マクロ 」編 ●

2 5,381 3   

「 印刷マクロ 」について、簡単ですが赤字で解説を入れました。
参考になれば、幸いです。

H25.06.20 現在
---------------------   ここから UForm1のコード    -------------------
[読込パス指定]ボタンクリックでブック読込先のディレクトリーを設定する。
Private Sub CommandButton1_Click()
    ' 読込パス指定
    パス設定
End Sub
------------------------------------------------------------------------
[プリント開始]ボタンクリックで写真読込先のディレクトリーを設定する。
Private Sub CommandButton3_Click()
    Pprint             <----  印刷を実行する。
End Sub
------------------------------------------------------------------------
[ファイル名取得]ボタンクリックでExcelブックのファイル名の取得を
実行する。
Private Sub CommandButton2_Click()
    ファイル名取得
End Sub
------------------------------------------------------------------------
[印刷プレピュー]チェックボックスをクリックで設定する。
Private Sub CheckBox1_Click()
    ' 印刷プレピュー
    ブック名のフッター印字フラグをリセットする。
    Workbooks(AAname).Worksheets(BBname).Cells(1, 7).Value = 0
    チェックボックス1にチェックが入ったら、印字フラグをONする。
    If UForm1.CheckBox1 = True Then 
          Workbooks(AAname).Worksheets(BBname).Cells(1, 7).Value = 1
End Sub
------------------------------------------------------------------------
[ファイル一覧消去]ボタンクリックでファイル一覧を消去する。
Private Sub CommandButton4_Click()
    ' ファイル一覧消去
セル位置 A5000から、A1 へ検索し、最初にデータのあるセル位置を取得する。
    NN = ActiveSheet.Range("A5000").End(xlUp).Row
    Crange = "A3:B" & CStr(NN)     <-- セル範囲指定のレンジデータを作る
    Range(Crange).Select                <-- データ消去のセル範囲を選択する
    Selection.ClearContents             <-- データ消去のセル範囲を選択する
    Range("A3").Select
End Sub
------------------------------------------------------------------------
[ブック名のフッター]オプションボタンにチェックが入ったら実行する。
Private Sub OptionButton1_Click()
    ' ブック名のフッター
    ブック名・シート名のフッター印字フラグをリセットする。
    Workbooks(AAname).Worksheets(BBname).Cells(1, 5).Value = 0
    Workbooks(AAname).Worksheets(BBname).Cells(1, 6).Value = 0
    オプションボタン1チェックが入ったら、印字フラグをONする。
    If UForm1.OptionButton1 = True Then 
          Workbooks(AAname).Worksheets(BBname).Cells(1, 6).Value = 1
End Sub
------------------------------------------------------------------------
[シート名のフッター]オプションボタンにチェックが入ったら実行する。
Private Sub OptionButton2_Click()
    ' シート名のフッター
    ブック名・シート名のフッター印字フラグをリセットする。
    Workbooks(AAname).Worksheets(BBname).Cells(1, 5).Value = 0
    Workbooks(AAname).Worksheets(BBname).Cells(1, 6).Value = 0
    オプションボタン2チェックが入ったら、印字フラグをONする。
    If UForm1.OptionButton2 = True Then 
          Workbooks(AAname).Worksheets(BBname).Cells(1, 5).Value = 1
End Sub
------------------------------------------------------------------------
[フッター追加なし]オプションボタンにチェックが入ったら実行する。
Private Sub OptionButton3_Click()
    ブック名・シート名のフッター印字フラグをリセットする。
    Workbooks(AAname).Worksheets(BBname).Cells(1, 5).Value = 0
    Workbooks(AAname).Worksheets(BBname).Cells(1, 6).Value = 0
End Sub
------------------------------------------------------------------------
UForm1の初期設定
Private Sub UserForm_Initialize()
    UForm1.TextBox1.Text = 1         <----  印刷枚数 1 を設定。
    '   [フッター追加なし]にチェックを入れる。
    UForm1.OptionButton3 = True
    ブック名・シート名のフッター印字フラグをリセットする。
    Workbooks(AAname).Worksheets(BBname).Cells(1, 5).Value = 0
    Workbooks(AAname).Worksheets(BBname).Cells(1, 6).Value = 0
    プレビューフラグをリセットする。
    Workbooks(AAname).Worksheets(BBname).Cells(1, 7).Value = 0
End Sub
--------------------   ここから ThisWorkBook コード --------------------
ブックを閉じた時に、アドインを消去する。
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    SA02リセット
End Sub
------------------------------------------------------------------------
ブックを開いた時に、アドインを表示する。
Private Sub Workbook_Open()
    SA01セット
End Sub

-------------------   ここから module1のコード    ----------------------
マクロブック・シートの名前を定義、変数の宣言
    Public Const AAname As String = "印刷マクロ.xlsm"
    Public Const BBname As String = "表紙"
    Public Bname, Sname, B5name, S6name, B7name, S8name As String
    Public MMM, MMM2, MMM3, AAAA As String
    Public A1, A2, A3, A4, A5, A6, A7, A8, A9, A10, ADir, Crange As String
    Public N, II As Integer
    Public Hosei, Hosei2, x, y, x0, y0, x1, y1, x2, y2, NN, N1, N2 As Long
-----------------------------------------------------------------------

ダイヤログを表示し、参照したいフォルダのパス情報を取得するサブルーチン。
プログラムは、下記のとおりにして下さい。
また、参照設定で [Microsoft shell Controls And Automation]の設定を忘れないようして下さい。
設定の仕方が、分からない方は、このマクロをダウロードし、不要な箇所を削除して、流用して ください。

[参照設定]のダイヤログの開き方
次の手順で、VBE(Visual Basic Editor)を開きます。

@[ツール] --> [マクロ] --> [マクロの表示] --> 適当なマクロを選び[編集] ----> Visual Basicのダイヤログが開きます。

A[ツール] --> [参照設定] --> 必要とするライブラリィにチェックをいれて [OK]


Sub フォルダ参照(SFolda, SFoldaB As Variant)
    '
    'このサブルーチンを使用するときは、下記2行の設定と
    '参照設定で Microsoft shell Controls And Automation の
    '参照設定をすること。
    'Private Const BIF_RETURNONLYFSDIRS As Long = &H1
    'Private Const BIF_EDITBOX As Long = &H10

    Dim myShell As Shell32.Shell
    Dim myFolder As Shell32.Folder3
    Dim myItem As Shell32.FolderItem
    Set myShell = New Shell32.Shell
    Set myFolder = myShell.BrowseForFolder( _
        0&, "フォルダを選択してください。" _
        , BIF_RETURNONLYFSDIRS Or BIF_EDITBOX)
    If myFolder Is Nothing Then SFolda = "": Exit Sub
    
        MsgBox myFolder.Self.Path
    
    SFolda = myFolder.Self.Path
   
    Set myFolder = Nothing
    Set myShell = Nothing
End Sub
---------------------------------------------------------------------------------
読込み先のディレクトリーを設定するサブルーチン。
Sub パス設定()
    '  写真の書込み側のパス設定
    
    フォルダ参照 SFolda, SFoldaB
    If SFolda = "" Then Exit Sub            <---- フォルダの指定が無い時は、
                                                                 強制終了する。
    ' 読込側のパス設定
    読込側のフォルダのパス設定を「マクロの表紙」に保存する。
    Workbooks(AAname).Worksheets(BBname).Cells(1, 3).Value = SFolda

End Sub
--------------------------------------------------------------------------------
Excelブックのファイル名を取得するサブルーチン
Sub ファイル名取得()
    個別に変数の宣言をする。
    Dim myPath, myFname, Bname, Sname, aa As String
    Dim NN, mm As Single
    ブック名・シート名を退避する。
    Bname = ActiveWorkbook.Name            ' ブック名取得
    Sname = Worksheets(1).Name             ' シート名取得
    '
    On Error GoTo ファイル名取得ERR00:      <----  エラーの時のジャンプ先
    読込側のフォルダのパス設定を「マクロの表紙」から、読み込む。
    ADir = Workbooks(AAname).Worksheets(BBname).Cells(1, 3).Value

    ブック名を書込むエリヤを消去する。
    一列目のセル位置5000から、上方向に検索し、最初にデータの有る
    セル位置 + 1 を取得する。

    NN = ActiveSheet.Range("A5000").End(xlUp).Row + 1
    Crange = "A3:B" & CStr(NN)      <---- 消去するセル範囲を作成する。
    Range(Crange).Select            <---- 消去するセル範囲を選択する。
    Selection.ClearContents         <---- 選択されたセル範囲をデータを消去
    Range("A3").Select
    ' ファイル名設定
    NN = 3: mm = 1             <---- 変数の初期値を設定する。
    '  パスの文字列に、パスの結合記号を追加する。
    myPath = ADir + "\"  
    '   変数 myFname に、Excelブック名だけをすべて読み込む。
    myFname = Dir(myPath & "*.xlsx")
    '   *.xlsxは、*.xls* と同じ意味になるので、
    '   *.xls、*.xlsx、*.xlsmを抽出してくれます。
    変数 myFname に、ブック名が、無くなるまで繰り返し実行する。
    Do While myFname <> ""
        '
        Cells(NN, 1).Value = mm            <---- 項番を書込む。
        Cells(NN, 2).Value = myFname       <---- ブック名を書込む。
        '
        NN = NN + 1: mm = mm + 1     <---- 変数をカウントアップする
        myFname = Dir()                    <---- 次のExcelブック名をセットする
    Loop
    '
    myFname = Dir(myPath & "*.xls")  <---- ファイル名取得
    '
    Do While myFname <> ""
        '
        Cells(NN, 1).Value = mm            <---- 番号
        Cells(NN, 2).Value = myFname       <---- ファイル名設定
        '
        NN = NN + 1: mm = mm + 1
        myFname = Dir()                    <----  ファイル名が無くなるまで実行
    Loop
    Exit Sub
    エラー処理 指定されたフォルダが無い時、警告メッセージを表示する。
ファイル名取得ERR00:
    N = Err.Number           <----  エラー番号を取得する。
    If N = 76 Then MsgBox ("指定フォルダは、ありません。")
End Sub

---------------------------------------------------------------------------------
リストで指定されて、Excelブックを印刷するサブルーチン
Sub Pprint()
    個別に変数の宣言をする。
Dim x1, x2, y1, y2, x, y, Scnt, II As Single
Dim Fname, Bname, Sname, folda, Xname As String
    印刷するリストの範囲を取得する。
    With ActiveWindow.RangeSelection
        y1 = .Columns.Column
        y2 = .Columns(.Columns.Count).Column
        x1 = .Rows.Row
        x2 = .Rows(.Rows.Count).Row
    End With                              ' ドラッグ範囲取得
    読込側のフォルダのパス設定を「マクロの表紙」から、読み込む。
    ADir = Workbooks(AAname).Worksheets(BBname).Cells(1, 3).Value
    '
    If ADir = "" Then Exit Sub     <-- バスの指定が無い時は、強制終了する
    ブック名・シート名を退避する。
    Bname = ActiveWorkbook.Name            ' ブック名取得
    Sname = Worksheets(1).Name             ' シート名取得
    テキストボックス1から、印刷枚数を取得し、数値に変換設定する。
    N = Val(UForm1.TextBox1.Text)
    x = x2 - x1           <----  指定されたブック名の数を計算する。
      Application.ScreenUpdating = False         <----  画面更新を停止する。
        
  For I = 0 To x
           Workbooks(Bname).Activate         <----  本マクロ表示する。
             「マクロの表紙」から、印刷ブックの名前を取得する。
           Fname = Worksheets(Sname).Cells(x1 + I, y1)
           ブックのフルパスを作成して、そのブックを開く。
           folda = ADir & "\"
           Workbooks.Open Filename:=folda & Fname   ' ファイルオープン
           Scnt = Worksheets.Count                   <--- シート枚数を取得する
     For II = 1 To Scnt
             シートを一番目から、順次開く。
            Worksheets(II).Activate
             フッタの印刷指定あるかの判定。
     if Workbooks(AAname).Worksheets(BBname).Cells(1, 5).Value = 0 _
And _Workbooks(AAname).Worksheets(BBname).Cells(1, 6).Value = 0 _
     Then GoTo Pprint01:
        シート名のフッタの印刷指定あるかの判定。
       If Workbooks(AAname).Worksheets(BBname).Cells(1, 5).Value = _
                              1 Then _Xname = "&6" & "  " & ActiveSheet.Name
        ブック名のフッタの印刷指定あるかの判定。
       If Workbooks(AAname).Worksheets(BBname).Cells(1, 6).Value = _
                         1 Then _Xname = "&6" & "  " & ActiveWorkbook.Name
        フッタの印刷指定をする。
       With ActiveSheet.PageSetup
                       .LeftFooter = Xname
       End With
                    
Pprint01:
       プレビュー指定あるかの判定。
If Workbooks(AAname).Worksheets(BBname).Cells(1, 7).Value = 0 Then
          指定枚数印刷する。
      ' 印刷
     ActiveWindow.SelectedSheets.PrintOut Copies:=N, Collate:=True 
  Else
          プレビューを表示する。
      ' 確認
     ActiveWindow.SelectedSheets.PrintPreview
  End If
    Next II
         '   警告メッセージの表示を停止する。
         Application.DisplayAlerts = False
         '    印刷対象ブックをアンティブにする。
         Windows(Fname).Activate       
         '    開いてたブックを閉じる。
         ActiveWindow.Close          
         '    警告メッセージの表示の停止を解除する。
         Application.DisplayAlerts = True
                
     Next I
        '  画面更新を停止を解除する。
     Application.ScreenUpdating = True 
   MsgBox "印刷終了"
End Sub

TOPへ戻る