エクセルだけで差し込み印刷（4) 機能追加をしました。
3-1 で 作成するブックが多いとエクセルが固まったように見えるので
1)実行時に何件あるのか表示確認
2)ステータスを更新する
3)マクロ終了時に作成フォルダを開く
これらの機能をインターネットで検索してマクロに追加しました。
それぞれの機能に必要なコマンドを調べました。
1) フィルタされて表示されている行数のみをカウントする。
これ、なかなか見つけるのが大変でした。
意味不明でした。 分解します
Ｒａｎｇｅ（）.Count,Cells(Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeVisible)
XCellTypeVisivle ： 見えているものだけカウントする
_複数の行を１行としてあつかう、意味不明でわからなかったのですが
一行が長くなる時に分けるセパレータでした。 一行ならなくても可能
' 行数カウント
cnt =Range(Range("A6"), Cells(Rows.Count, 1).End(xlUp))
_SpecialCells(xlCellTypeVisible).Count
列の下から数えてA6まで、値が入っているの行数を調べる
' A6からのカウントなので １行引く
cntL = cnt - 1
'実行確認メッセージ
If MsgBox("件数" & cntL & "件、実行しますか？ ", vbYesNo) = vbNo Then
End
End If
2) ステータスの更新
これは簡単に見つかった、 左下に何件シートを処理しているか表示します
' ステータスバーに書き込む
Application.StatusBar = "処理実行中．．．．(現在 " & uFile & "件)"
放置すると 最後の件数が表示されっぱなしになるので消去
'ステータスバーの消去
Application.StatusBar = False
3) マクロ終了時フォルダを開く
'使用したフォルダを開く
CreateObject("Shell.Application").Open SaveDir
前へ 次へ
---------------------------------
Sub book作成35()
'画面のちらつきを防止する
Application.ScreenUpdating = False
'リストワークシートを選択する
Worksheets("リスト").Activate
'リストワークシートのセルA6をアクティブセルにする
Range("A6").Select
' 行数カウント
cnt = Range(Range("A6"), Cells(Rows.Count, 1).End(xlUp)) _
.SpecialCells(xlCellTypeVisible).Count
' A6からのカウントなので １行引く
cntL = cnt - 1
'実行確認メッセージ
If MsgBox("件数" & cntL & "件、実行しますか？ ", vbYesNo) = vbNo Then
End
End If
'ユニークファイル番号の設定、ブックを作成するときの番号を１から順につけるために必要
uFile = 0
' Save Directory の パス設定
パス = ActiveWorkbook.Path ' カレントパスの取得
SaveDir = パス & "\" & Format(Date, "yyyymmdd")
' カレントパス,日付のフォルダがある場合はフォルダ削除して再度作成
If Dir(SaveDir, vbDirectory) <> "" Then
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.DeleteFolder SaveDir
Set FSO = Nothing
MkDir SaveDir
Else
MkDir SaveDir
End If
'ループの開始
Do
'アクティブセルを１つ下に移動する A7になる
ActiveCell.Offset(1, 0).Select
'空欄であれば、プログラムを終了する
'Trim関数は前後のスペースを消去する
If Trim(ActiveCell.Value) = "" Then
Exit Do
End If
'非表示セルは対象としない
If ActiveCell.EntireRow.Hidden = False Then
'Format1 シートにリストの内容を繁栄される
With Worksheets("Format1")
'レコードの先頭セルを選択
'Format1 D10に リストの A7の内容を移動
.Range("D10").Value = ActiveCell.Offset(0, 0).Value
'Format1 D12に リストのA7から指定セルを移動するために 上下方向0, 右方向に１移動
.Range("D12").Value = ActiveCell.Offset(0, 1).Value
.Range("F12").Value = ActiveCell.Offset(0, 2).Value
'レコードの最終セルであれば、Format１シートをsaveする
Sheets("Format1").Select 'シートをアクティブにする
' ユニークファイル番号の設定
uFile = uFile + 1
'名前重複排除 別名を作成 フォーマットは 1-D12-F12.xls とする
別名 = SaveDir & "\" & uFile & "-" & Range("D12") & "-" & Range("F12") & ".xls" 'パスと拡張子を付ける
Sheets("Format1").Copy 'シートを新規ブックへコピー ※１
ActiveWorkbook.SaveAs Filename:=別名, FileFormat:=XlFileFormat.xlExcel8 '別名を付けてブックを保存する
ActiveWorkbook.Close '別名ブックを閉じる
Sheets("リスト").Select ' リストシートをアクティブにする
' ステータスバーに書き込む
Application.StatusBar = "処理実行中．．．．(現在 " & uFile & "件)"
End With
End If
'ループの終了
Loop
'ステータスバーの消去
Application.StatusBar = False
'使用したフォルダを開く
CreateObject("Shell.Application").Open SaveDir
End Sub
