B-Teck!

お仕事からゲームまで幅広く

【VBA/Excel】Excelの印刷総ページ数を取得してCSVで出力する

VBA 
Option Explicit
'/**
' * getExcelProp
' * 与えられたパスに存在する、与えられた拡張子のExcelについて
' * [ファイル名],[ページ数]のカンマ区切りの形式でString配列を作成する
' * @param  filePath ファイルの存在するパス 末尾に\が必要
' * @param  fileType 拡張子
' * @return [ファイル名],[ページ数]のカンマ区切りString配列
' */
Function getExcelProp(ByVal filePath As String, ByVal fileType As String) As String()
    Dim wkBook As Workbook: Set wkBook = Nothing    '開くワークブックオブジェクト
    Dim buf As String                               'ファイル名用バッファ
    Dim page As Long                                'ファイル毎の総ページ数
    Dim i As Long                                   'Forのカウンタ
    Dim retVal() As String: ReDim retVal(0)         '戻り値用配列

On Error GoTo Proc_Exit
    ' 処理速度向上の為非表示
    Application.Visible = False
    ' ダイアログ非表示
    Application.DisplayAlerts = False

    buf = Dir(filePath & "*." & fileType)
    Do While buf <> ""
        'ページ数初期化
        page = 0
        
        'ページ数集計
        Set wkBook = Workbooks.Open(filePath & buf)
        For i = 1 To wkBook.Sheets.Count
            '2010以前のバグ対応のため改ページプレビューに切り替える
            wkBook.Sheets(i).Select
            ActiveWindow.View = xlPageBreakPreview
            
            'どっちを書いてもカウントできる
            page = page + wkBook.Sheets(i).PageSetup.Pages.Count
            'page = page + Application.ExecuteExcel4Macro("get.document(50)")
        Next i
        
        '動的に配列増やす(コスト的には微妙…)
        ReDim Preserve retVal(UBound(retVal) + 1)
        'ファイル名,ページ数の形で配列に格納
        retVal(UBound(retVal) - 1) = buf & "," & page
        
        wkBook.Close
        Set wkBook = Nothing
        buf = Dir()
    Loop
    
Proc_Exit:
    ' エラー時にクローズできてないワークブックを閉じる
    If Not wkBook Is Nothing Then
        wkBook.Close
        Set wkBook = Nothing
    End If
    
    'ダイアログ・アプリケーションを表示するように戻す
    Application.DisplayAlerts = True
    Application.Visible = True
    getExcelProp = retVal
End Function

'/**
' * OutputCsv
' * 文字列配列からCSVを作成する
' * @param  varData 文字列配列
' * @return なし
' */
Public Sub OutputCsv(ByVal varData As Variant)
    
    Dim lngFileNum As Long
    Dim strFileNm As String
    Dim strOutPutFile As String
    Dim item As Variant
    
    'ファイル名を現在の日付にする
    strFileNm = Format(Now(), "yyyymmdd") & ".csv"
        
    ' 出力先ディレクトリ設定
    ' とりあえずこのExcelファイルと同じフォルダに出力
    strOutPutFile = ActiveWorkbook.Path & "\" & strFileNm
    
    'ファイル作成(または追記モードでオープン)
    lngFileNum = FreeFile()
    Open strOutPutFile For Append As #lngFileNum
    
    ' 配列の中身を一行ずつ追記
    For Each item In varData
        If item <> "" Then
            Print #lngFileNum, item
        End If
    Next item
    
    Close #lngFileNum

End Sub

Sub test()
    
    'OutputCsv (getExcelProp(ファイルパス, "xls"))
End Sub