2011/01/16

指定フォルダ内にあるExcelファイルの印刷ページ数を数えるマクロ

Excelファイルのページ数を数えなければいけない作業があった。

作業手順は
1.Excelファイルを開き、「すべてのシートを選択」でシートを全部選択した状態にする。
2.「印刷プレビュー」を開き、左下に表示されるページ数を確認する。

ファイル数が100を超えており、
いちいちファイルを開いて上記の作業をするのがとても面倒だったので
割と適当な Excelのマクロを作ってみた。


このマクロが行っていることは
マクロを保存したExcelファイルに新規のシートを追加して、
指定のフォルダ内にある各 Excelファイルの
「ページ数」「フォルダパス」「ファイル名」を出力するだけ。

↓ちなみに参考にしたページ↓
印刷されるページの総数を調べる方法

以下、作成手順。
1.Excel を新規で開く。
2.「Alt + F11」を押して「Visual Basic Editor」を開く。
3.「Visual Basic Editor」の左側にある「プロジェクト-VBAProject」の「VBAProject(Book1)」を右クリックする。
4.「挿入」-「標準モジュール」を選択する。
5.「Module1」が追加されるので、「Module1」を右クリックして「コードの表示」を選択する。
6.右側のコード記述スペースに以下のソースを貼り付ける。
7.貼り付けが終わったら、保存ボタンを押して適当に保存し、「Visual Basic Editor」を閉じる。

※マクロを使用するので
「マクロのセキュリティ」を「中」以下に設定する必要がある。

以下がサンプルソース。

別ウィンドウでみる



Option Explicit
Public Sub CountPrintPages()
'-------------------------------------------------------------------------------
'概要 :アクティブになっているブックの印刷枚数をカウントする
'機能名 :CountPrintPages
'引数 :なし
'戻り値 :なし
'備考 :「すべてのシートを選択」して「印刷プレビュー」したときの印刷枚数を数えます
'-------------------------------------------------------------------------------

Dim i_Hbreak As Integer
Dim i_Vbreak As Integer
Dim i_Page As Integer
Dim s_Cell As String

Dim xlApp As Excel.Application
Dim xlBook As Workbook
Dim xlSheet As Worksheet
Dim l_RowNo As Long '書き込む行数

Dim l_SumPage As Long '印刷ページ総数(各ブック単位)
Dim l_TotalPage As Long '印刷ページ総数(全ブック)
Dim s_Msg As String
Dim s_FolderPath As String
Dim s_FileName As String

'全ページ数書き込み用
Const CNST_CELL_RET_TITLE As String = "A2"
Const CNST_CELL_RET_ALLPAGES As String = "B2"

'各ファイルの情報書き込み用
Const CNST_COL_PAGES As String = "B"
Const CNST_COL_FOLDER As String = "C"
Const CNST_COL_FILE As String = "D"

'書き込み開始行
Const CNST_ROW_KAISHI As Long = 4

On Error GoTo ErrTrap

'-----------------------------
'初期化
'-----------------------------
l_TotalPage = 0
s_Msg = ""


'-----------------------------
'メイン
'-----------------------------
'フォルダの選択
s_FolderPath = getFolderPath

If s_FolderPath = "" Then
'選ばなかった⇒終了
Exit Sub
End If

'xlsファイル名を取得
s_FileName = Dir(s_FolderPath & "\*.xls")

If s_FileName = "" Then
'一個もない⇒終了
MsgBox "Excelファイルがありません", vbInformation
Exit Sub
Else
'エクセル起動
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
End If

'書込み開始行
l_RowNo = CNST_ROW_KAISHI

'シートを追加
ThisWorkbook.Worksheets.Add After:=Sheets(ActiveWorkbook.Sheets.Count)

'項目名
ThisWorkbook.ActiveSheet.Range(CNST_COL_PAGES & CStr(l_RowNo)).Value = "ページ数"
ThisWorkbook.ActiveSheet.Range(CNST_COL_FOLDER & CStr(l_RowNo)).Value = "フォルダパス"
ThisWorkbook.ActiveSheet.Range(CNST_COL_FILE & CStr(l_RowNo)).Value = "ファイル名"

Do Until (s_FileName = "")
'Book を開く
Set xlBook = xlApp.Workbooks.Open(s_FolderPath & "\" & s_FileName)

l_SumPage = 0

For Each xlSheet In xlBook.Worksheets
'最後のセルのアドレスを取得
s_Cell = xlSheet.UsedRange.Address
If s_Cell = "$A$1" Then
If IsEmpty(xlSheet.Range(s_Cell).Value) Then
'印刷できるページがない
GoTo NEXT_SHEET
End If
End If
'横の改ページ数取得
i_Hbreak = xlSheet.HPageBreaks.Count
'縦の改ページ数取得
i_Vbreak = xlSheet.VPageBreaks.Count
If i_Vbreak = 0 Then
i_Page = i_Hbreak + 1
Else
i_Hbreak = i_Hbreak + 1
i_Vbreak = i_Vbreak + 1
i_Page = i_Hbreak * i_Vbreak
End If

l_SumPage = l_SumPage + i_Page

NEXT_SHEET:
Next xlSheet

'書込み
l_RowNo = l_RowNo + 1
ThisWorkbook.ActiveSheet.Range(CNST_COL_PAGES & CStr(l_RowNo)).Value = l_SumPage
ThisWorkbook.ActiveSheet.Range(CNST_COL_FOLDER & CStr(l_RowNo)).Value = s_FolderPath & "\"
ThisWorkbook.ActiveSheet.Range(CNST_COL_FILE & CStr(l_RowNo)).Value = s_FileName


l_TotalPage = l_TotalPage + l_SumPage

'Book 閉じる
GoSub CLOSE_XLSBOOK

s_FileName = Dir()
Loop

'-----------------------------
'終了処理
'-----------------------------
'開いたExcelを閉じる
GoSub CLOSE_EXCEL

'最終結果書込み
ThisWorkbook.ActiveSheet.Range(CNST_CELL_RET_TITLE).Value = "全ページ数"
ThisWorkbook.ActiveSheet.Range(CNST_CELL_RET_ALLPAGES).Value = l_TotalPage

'処理終了メッセージ
MsgBox "正常に処理が終了しました \(^o^)/ ", , "終了確認"

Exit Sub
CLOSE_XLSBOOK:
'Book閉じる
If Not xlBook Is Nothing Then
xlBook.Close
Set xlBook = Nothing
End If
Return
CLOSE_EXCEL:
'Excel閉じる
If Not xlApp Is Nothing Then
xlApp.Quit
Set xlApp = Nothing
End If
Return
ErrTrap:
GoSub CLOSE_XLSBOOK
GoSub CLOSE_EXCEL
MsgBox Err.Description, vbCritical
End Sub

Public Function getFolderPath() As String
'-------------------------------------------------------------------------------
'概要 :ユーザーにフォルダを選ばせてフォルダパスを取得する
'機能名 :getFolderPath
'引数 :なし
'戻り値 :フォルダ選択時:フォルダパス フォルダ未選択時:空文字
'備考 :
'-------------------------------------------------------------------------------

Dim Shell As Object
Dim myPath As Variant
Dim s_FolderPath As String

s_FolderPath = ""

Set Shell = CreateObject("Shell.Application")
Set myPath = Shell.BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10, "C:\")
If Not myPath Is Nothing Then
s_FolderPath = myPath.Items.Item.Path
End If

Set Shell = Nothing
Set myPath = Nothing

getFolderPath = s_FolderPath

End Function

以下、実行手順。
1.Excel を選択している状態で「Alt + F8」を押してマクロ実行画面を出す。
マクロの実行
2.「CountPrintPages」を選択して「実行」を押す。
3.フォルダ選択の画面が出るので、ページ数を知りたい Excel ファイルが入っているフォルダを選択する。(複数ファイルが入っていても可)
フォルダの選択
4.「OK」を押す。
5.結果を確認する。
印刷ページ数をカウントした結果

以上

[広告]



関連記事

スポンサーリンク

スポンサーリンク

スポンサーリンク

コメント

非公開コメント

素晴らしい

マクロは素晴らしいです。マクロに苦手の方なら、
以下の方法でもお勧めします。
http://superdbtool.com/blog/archives/152

管理人のみ閲覧できます

このコメントは管理人のみ閲覧できます