複数のExcelファイルを一括でPDFファイルに変換するマクロ(ExcelVBA)

複数のExcelファイルを一括でPDFファイルに変換するマクロ(ExcelVBA)になります。

ネットに備忘録として挙げられてる方がいて昔から不思議だったんですけど、色々な職場に行かれる方は以前作成したコードを使える様にしているんですね。

他の職場にコードは持っていけないけど、ネットに上げているコードなら使えるんですね。

しかも、個人のPCを使用して作業しているので、客先の工数に入れる事なく作業ができるのがいいですね。

概要

ExcelファイルをPDFファイルに変換する必要があったので、ExcelVBAで作りました。

汎用性とか考えていないので、PERSONAL.XLSBとして動作する事しか見ていません。

開いているExcelファイルと同ディレクトリーの 拡張子”.xls””.xlsx”のファイルをPDFファイルに変換します。

ExportAsFixedFormat

Workbook.ExportAsFixedFormat メソッド (Excel)

Office VBA リファレンス トピック

learn.microsoft.com

コード

Option Explicit

Const EXT_NAME_XLS = ".xls"
Const EXT_NAME_XLSX = ".xlsx"
Const EXT_NAME_PDF = ".pdf"

' ------------------------------------------------------------
' PDFファイルの作成
' ------------------------------------------------------------
Sub SavePDF()
    Dim ext                 As String
    Dim buf                 As String
    Dim dir_full_path       As String
    Dim file_name           As String
    Dim file_full_path_app  As String
    Dim file_full_path_pdf  As String
    Dim pos                 As Integer

    ' カレントディレクトリーの取得
    dir_full_path = ActiveWorkbook.Path

    buf = Dir(dir_full_path & "\*.*")
    Do While buf <> ""
        ' "."の位置の取得
        pos = InStrRev(buf, ".")

        ' 拡張子の取得
        ext = Right(buf, Len(buf) - pos + 1)
        ' 対象の拡張子は".xls"".xlsx"のみとする
        If (ext <> EXT_NAME_XLS) And (ext <> EXT_NAME_XLSX) Then
            GoTo CONTINUE
        End If

        ' 拡張子のないファイル名称の取得
        file_name = Left(buf, pos - 1)

        ' ファイルパスの作成
        file_full_path_app = dir_full_path & "\" & file_name & ext
        file_full_path_pdf = dir_full_path & "\" & file_name & EXT_NAME_PDF

        ' Excelファイルを開く
        Workbooks.Open file_full_path_app

        ' PDFファイルで保存
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=file_full_path_pdf

        ' Excelファイルを保存しないで閉じる
        ActiveWorkbook.Close SaveChanges:=False

CONTINUE:
        buf = Dir()
    Loop

    MsgBox "PDFFファイル作成完了"
End Sub