|
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のダイヤログが開きます。
②[ツール] --> [参照設定] --> 必要とするライブラリィにチェックをいれて [OK]
Sub フォルダ参照(SFolda, SFoldaB As Variant)
'
'このサブルーチンを使用するときは、下記２行の設定と
'参照設定で 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 |
|