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

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

以下、作成手順。
１．Excel を新規で開く。
２．「Alt + F11」を押して「Visual Basic Editor」を開く。
３．「Visual Basic Editor」の左側にある「プロジェクト-VBAProject」の「VBAProject(Book1)」を右クリックする。
４．「挿入」-「標準モジュール」を選択する。
５．「Module1」が追加されるので、「Module1」を右クリックして「コードの表示」を選択する。
６．右側のコード記述スペースに以下のソースを貼り付ける。
７．貼り付けが終わったら、保存ボタンを押して適当に保存し、「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

以下、実行手順。
１．Excel を選択している状態で「Alt + F8」を押してマクロ実行画面を出す。

２．「CountPrintPages」を選択して「実行」を押す。
３．フォルダ選択の画面が出るので、ページ数を知りたい Excel ファイルが入っているフォルダを選択する。(複数ファイルが入っていても可)

４．「OK」を押す。
５．結果を確認する。


以上

[広告]

関連記事

• ExcelのVBAで差集合を求める関数を作ってみた
• ExcelVBAを書くときに気を付けていること　その１
• Oracleのテーブル定義書を自動で作成するツール
• Excel VBA のフォルダの参照
• 指定フォルダ内にあるExcelファイルの印刷ページ数を数えるマクロ

スポンサーリンク