トップ　>　汎用コード　>　PDFファイルに一括変換

PDFファイルに一括変換2019.01.20　更新：2024.11.11

あるフォルダ内のExcel、Word、及びPowerPointファイルをPDFファイルに一括変換するコードです。
コードを実行すると、フォルダ選択ダイアログが表示され、フォルダを選択するとPDF化の処理が始まります（印刷対象がないファイルはPDF化はされません）
ファイルのサイズ等によっては多少時間を要する場合があります。
次の例のように、指定フォルダ内に同じファイル名が存在する場合、出力されるPDFファイルは上書きされますので気を付けてください。
【例】英語1.xlsx　英語1.docx

【書籍紹介】「Excel VBA 逆引きで学ぶ ユーザーフォーム&コントロール」

【お薦め】マクロ・プロシージャを管理する無料のツール！
　Excelマクロ管理ツール

サンプルコード2019.01.20　更新：2024.08.06

コードの貼り付け場所　　　VBAコードをカラーで印刷・Web掲載するためのツールはこちら 

'------------------------------------------------------------
' 指定フォルダのExcel/Word/PowerPointをPDFとして一括出力処理
'------------------------------------------------------------
' https://excel.syogyoumujou.com/vba/conv_pdf.html
'------------------------------------------------------------
Sub ConvertToPdf()
    'フォルダの選択
    Dim strFolderPath As String
     With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            strFolderPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    'フォルダ内の全ファイルパス取得
    Dim colFilePath As Collection
    Set colFilePath = GetFilePath(strFolderPath)
    If colFilePath.Count = 0 Then Exit Sub 'ファイルパスがなければ終了
    
    '出力フォルダ名
    Dim strOutputFolderName As String
    strOutputFolderName = "PDF"
    
    '区切り文字取得
    Dim strPathSeparator As String
    strPathSeparator = Application.PathSeparator
    
    '出力フォルダ名の前に区切り文字追加
    strOutputFolderName = strPathSeparator & strOutputFolderName
    
    'PDF出力先フォルダ作成
    If Dir(strFolderPath & strOutputFolderName, vbDirectory) = "" Then 'フォルダ存在確認
        MkDir strFolderPath & strOutputFolderName 'PDF用フォルダ作成
    End If

    '対象ファイルをPDFとして出力
    On Error Resume Next
    Application.ScreenUpdating = False
    Dim i           As Long
    Dim strFileName As String
    For i = 1 To colFilePath.Count
        If ThisWorkbook.Path <> colFilePath(i) Then
            'ファイルパスからファイル名取得
            strFileName = Dir(colFilePath(i))
            'ファイル名の前に区切り文字追加
            strFileName = strPathSeparator & strFileName
            Call OutputPdfMainProcessing(strFolderPath, strOutputFolderName, strFileName)
        End If
    Next
    Application.ScreenUpdating = True
    
    'マクロ実行ブックもPDF出力する場合は以下をコメントアウト
'    strFileName = ThisWorkbook.Name
'    If 0 < InStr(1, strFileName, ".") Then
'        strFileName = Left$(strFileName, InStrRev(strFileName, ".") - 1)
'    End If
'    ThisWorkbook.ExportAsFixedFormat _
'        Type:=xlTypePDF, _
'        FileName:=strFolderPath & strOutputFolderName & strPathSeparator & strFileName, _
'        OpenAfterPublish:=False
    On Error GoTo 0
End Sub


'------------------------------------------------------------
' 指定フォルダ内の全ファイルパス取得関数
'------------------------------------------------------------
'［引数］
'   FolderPath ：対象フォルダパス
'［戻り値］
'   Collectionオブジェクト　各要素にファイルパスが格納される
'------------------------------------------------------------
Function GetFilePath(ByVal FolderPath As String) As Collection
    Set GetFilePath = New Collection
    Dim c   As Long
    Dim FSO As Object
    Dim F   As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    For Each F In FSO.GetFolder(FolderPath).Files
        c = c + 1
        GetFilePath.Add F.Path, CStr(c)
    Next
End Function


'--------------------------------------------------------------------
' Excel/Word/PowerPointのPDF出力メイン処理
'--------------------------------------------------------------------
'［引数］
'   FolderPath      ：対象フォルダパス
'   OutputFolderName：区切り文字 & 出力フォルダ名　【例】\PDF
'   FileName        ：区切り文字 & 対象ファイル名　【例】\sample.xlsx
'--------------------------------------------------------------------
Sub OutputPdfMainProcessing(ByVal FolderPath As String, _
                            ByVal OutputFolderName As String, _
                            ByVal FileName As String)
    '対象ファイルのパス
    Dim TargetFilePath As String
    TargetFilePath = FolderPath & FileName
    
    '対象ファイルのパスから拡張子名を取得
    Dim strExtensionName As String
    With CreateObject("Scripting.FileSystemObject")
        strExtensionName = .GetExtensionName(TargetFilePath)
    End With
    
    'PDF出力ファイルフルパス作成
    Dim OutputFullPath As String
    If 0 < InStrRev(FileName, ".") Then
        FileName = Left$(FileName, InStrRev(FileName, ".")) & "pdf"
    Else
        FileName = FileName & ".pdf"
    End If
    OutputFullPath = FolderPath & OutputFolderName & FileName

    'Excel/Word/PowerPointの場合はPDFファイルとして出力
    Dim objOffice As Object
    Select Case strExtensionName '拡張子名でファイルを判定
    Case "xls", "xlsx" 'Excel97-2003,Excel2007以降
        Set objOffice = Excel.Application
        With objOffice.Workbooks.Open(TargetFilePath)
            .ExportAsFixedFormat Type:=xlTypePDF, _
            FileName:=OutputFullPath, OpenAfterPublish:=False
            .Close False
        End With
    Case "doc", "docx" 'Word97-2003,Word2007以降
        Set objOffice = CreateObject("Word.Application")
        With objOffice.Documents.Open(TargetFilePath)
            .ExportAsFixedFormat OutputFileName:=OutputFullPath, _
            ExportFormat:=17
            .Close
        End With
        objOffice.Quit
    Case "ppt", "pptx" 'PowerPoint97-2003,PowerPoint2007以降
        Set objOffice = CreateObject("PowerPoint.Application")
        With objOffice.Presentations.Open(TargetFilePath)
            .SaveAs FileName:=OutputFullPath, FileFormat:=32
            .Close
        End With
        objOffice.Quit
    End Select
End Sub

指定したフォルダ内にPDFフォルダを新たに作成し、そのPDFフォルダ内にPDF化されたファイルが作成されていきます。

書籍紹介本を執筆しました

好評販売中！
「教師のExcel　～校務（個人業務＋チーム業務）カイゼンのためのデジタルリテラシー～」
基本の学びなおしから校務をサポートするシステム作りまで（技術評論社）

教員みんなができる「チーム業務」のポイントを丁寧にわかりやすく解説しています。また「個人業務」を更に効率化するための学び直しと応用テクニックを解説しています。
この書籍の活用してもらうことで、先生方が児童・生徒に向き合う時間を、更に確保できることを願っています！
■ 詳細（技術評論社）　　　■ 内容紹介：note　　　■ 購入：amazon


汎用コードのリクエストをいただきました。

リクエスト 12024.11.11

「開いている全てのExcelの全シートをシート名のPDFファイルとして出力」
開いている全てのExcelの全シートを、1シートずつPDFファイルとして出力するコードです。
マクロ「outputAllOpenExcelSheetsAsPDF」を実行し出力フォルダを選択すると処理が開始されます。

処理は、処理開始時点で開いている全てのExcelブックを対象とします（アドイン等は除く）。Excelブック毎に、選択フォルダ内に新規フォルダが作成され、その作成されたフォルダ内にシート毎のPDFファイルが出力されます。
PDFファイルのファイル名は出力対象となったシート名になります。
出力されるファイル名と同名のPDFファイルが既に存在した場合は、ファイルが上書きされますので気をつけてください。
また、Excelのファイル数やシート数が多い場合には、処理に時間を要しますので気をつけてください。 

'-------------------------------------------------------------
' 現在開いているExcelの全シートをシート名のPDFファイルとして出力
'-------------------------------------------------------------
' ※　コード内でフォルダを選択しますが、そのフォルダの
' 　　書き込み権限がないとエラーになります
' 　　エラーが発生した場合にはPDFファイルは出力されません
'［掲載ページ］
' https://excel.syogyoumujou.com/vba/conv_pdf.html
'-------------------------------------------------------------
Sub outputAllOpenExcelSheetsAsPDF()
    '-------------------------------
    ' 実行確認メッセージ
    '-------------------------------
    Const L_MESSAGE As String = "開いている全てのExcelファイルの全シートを" & _
                                "それぞれPDFファイルとして出力しますか？"
    If MsgBox(L_MESSAGE, vbQuestion + vbYesNo) = vbNo Then Exit Sub

    '-------------------------------
    ' ファイル出力先フォルダの選択
    '-------------------------------
    Dim strFolderPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "PDFファイル出力先フォルダを選択してください"
        If .Show Then
            strFolderPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With

    '-------------------------------
    ' 開いているExcelの全シートを出力
    '-------------------------------
    Dim wbk As Workbook
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    For Each wbk In Workbooks
        Call outputOpenExcelSheetsAsPDF(wbk, strFolderPath)
    Next
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    MsgBox "終了しました"
    
    'フォルダを表示
    Shell "C:\Windows\Explorer.exe " & strFolderPath, vbNormalFocus
End Sub


'------------------------------------------------------------
' 開いているExcelの全シートをそれぞれPDF出力するプロシージャ
'------------------------------------------------------------
' ※非表示シートは出力対象外です
' ※印刷対象が存在しないシートはPDF出力されません
'［引数］
'   wbkTarget ：対象ブック
'   FolderPath：出力用フォルダパス
'［作成日］2024.11.11
'------------------------------------------------------------
Private Sub outputOpenExcelSheetsAsPDF(ByRef wbkTarget As Workbook, _
                                       ByVal FolderPath As String)
On Error Resume Next
    ' ファイル名取得
    Dim strFileName As String
    strFileName = wbkTarget.Name
        
    ' 出力用フォルダパスにフォルダ区切り文字追加
    FolderPath = FolderPath & Application.PathSeparator

    ' 対象ブック用の出力フォルダ名生成
    If InStr(1, strFileName, ".") = 0 Then
        FolderPath = FolderPath & strFileName
    Else
        FolderPath = FolderPath & Left$(strFileName, InStrRev(strFileName, ".") - 1)
    End If

    ' 対象ブック用のフォルダ作成
    If Dir(FolderPath, vbDirectory) = "" Then
        MkDir FolderPath
    End If
    
    ' 対象ブックの各シートをPDFとして出力
    Dim sht            As Worksheet
    Dim strPdfFilePath As String
    Dim strPdfFileName As String
    For Each sht In wbkTarget.Worksheets
        ' 表示されているシートを出力対象とする
        If sht.Visible = xlSheetVisible Then
            ' ファイル名禁止文字列をアンダーバー(_)に置換
            strPdfFileName = replaceForbiddenCharactersFromFileName(sht.Name, "_")
            
            ' シート名をファイル名とした出力ファイルパスの作成
            strPdfFilePath = FolderPath & Application.PathSeparator & strPdfFileName & ".pdf"
            
            ' 対象シートをPDF出力
            sht.ExportAsFixedFormat _
                Type:=xlTypePDF, FileName:=strPdfFilePath, OpenAfterPublish:=False
        End If
    Next
On Error GoTo 0
End Sub


'--------------------------------------------------------
' ファイル名禁止文字置換関数
'--------------------------------------------------------
'［引数］
'   FileName    ：対象ファイル名の文字列
'   ReplaceSting：置換後文字列（既定：空の文字列）
'［戻り値］
'   ファイル名禁止文字を置換した文字列
'［作成日］2023/03/26　［更新日］2023/12/20
' https://excel.syogyoumujou.com/vba/conv_pdf.html
'--------------------------------------------------------
Private Function replaceForbiddenCharactersFromFileName(ByVal FileName As String, _
                                                        Optional ReplaceString As String = "") As String
    Dim varRemoveCharacters As Variant
    varRemoveCharacters = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    Dim i As Long
    For i = 0 To UBound(varRemoveCharacters)
        FileName = Replace$(FileName, varRemoveCharacters(i), ReplaceString, , , vbBinaryCompare)
    Next
    replaceForbiddenCharactersFromFileName = FileName
End Function

リクエスト 22023.10.20　更新：2024.08.06

「指定フォルダのExcelの全シートをシート名のPDFファイルとして出力」
指定フォルダ内のExcelの全シートを、1シートずつPDFファイルとして出力するコードです。
マクロ「outputAllExcelSheetsAsPDF」を実行しフォルダを選択すると処理が開始されます。
処理は、選択したフォルダ内のExcelを対象とします。Excelブック毎に、選択フォルダ内に新規フォルダが作成され、その作成されたフォルダ内にシート毎のPDFファイルが出力されます。PDFファイルのファイル名は出力対象となったシート名になります。
出力されるファイル名と同名のPDFファイルが既に存在した場合は、ファイルが上書きされますので気をつけてください。
また、Excelのファイル数やシート数が多い場合には、処理に時間を要しますので気をつけてください。 

'-------------------------------------------------------------
' 指定フォルダのExcelの全シートをシート名のPDFファイルとして出力
'-------------------------------------------------------------
' ※　コード内でフォルダを選択しますが、そのフォルダの
' 　　書き込み権限がないとエラーになります
' 　　エラーが発生した場合にはPDFファイルは出力されません
'［掲載ページ］
' https://excel.syogyoumujou.com/vba/conv_pdf.html
'-------------------------------------------------------------
Sub outputAllExcelSheetsAsPDF()
    'フォルダの選択
    Dim strFolderPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then
            strFolderPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With

    'フォルダ内の全Excelファイルパス取得
    Dim colFilePath As Collection
    Set colFilePath = getExcelFilePath(strFolderPath)
    If colFilePath.Count = 0 Then 'ファイルパスがなければ終了
        MsgBox "指定のフォルダにファイルが見つかりません", vbInformation
        Exit Sub
    End If
    
    'Excelファイルの全シートをPDFファイルとして出力
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim i As Long
    For i = 1 To colFilePath.Count
        If ThisWorkbook.Path <> colFilePath(i) Then
            Call outputSheetsAsPDF(strFolderPath, colFilePath(i))
        End If
    Next
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    MsgBox "終了しました"
    
    'フォルダを表示
    Shell "C:\Windows\Explorer.exe " & strFolderPath, vbNormalFocus
End Sub


'------------------------------------------------------------
' 対象フォルダ内の全Excelファイルパス取得関数
'------------------------------------------------------------
' 対象ファイルタイプ：xls/xlsx/xlsm/xlsb
'［引数］
'   FolderPath ：対象フォルダパス
'［戻り値］
'   Collectionオブジェクト　各要素にファイルパスが格納される
'［作成日］2023.10.19   ［更新日］2023.12.20
' https://excel.syogyoumujou.com/vba/conv_pdf.html
'------------------------------------------------------------
Private Function getExcelFilePath(ByVal FolderPath As String) As Collection
    Set getExcelFilePath = New Collection
    Dim lngCount         As Long
    Dim strFileName      As String
    Dim strPathSeparator As String
    strPathSeparator = Application.PathSeparator
    strFileName = Dir(FolderPath & strPathSeparator & "*.xls?")
    Do Until strFileName = ""
        If ThisWorkbook.FullName <> FolderPath & strPathSeparator & strFileName Then
            lngCount = lngCount + 1
            getExcelFilePath.Add FolderPath & strPathSeparator & strFileName, CStr(lngCount)
        End If
        strFileName = Dir() '次のファイル確認
    Loop
    strFileName = Dir("")
End Function


'------------------------------------------------------------
' Excelファイルの全シートをそれぞれPDF出力するプロシージャ
'------------------------------------------------------------
'［引数］
'   FolderPath：Excelファイルが格納されているフォルダパス
'   FilePath  ：対象のExcelファイルパス
'------------------------------------------------------------
Private Sub outputSheetsAsPDF(ByVal FolderPath As String, _
                              ByVal FilePath As String)
    On Error Resume Next
    'ファイル名取得
    Dim strFileName As String
    strFileName = Dir(FilePath)
    
    'フォルダ作成
    FolderPath = FolderPath & "\" & Left$(strFileName, InStrRev(strFileName, ".") - 1)
    If Dir(FolderPath, vbDirectory) = "" Then
        MkDir FolderPath
    End If
    
    '各シートをPDFとして出力
    Dim Sh             As Worksheet
    Dim strPdfFilePath As String
    Dim strPdfFileName As String
    With Workbooks.Open(FilePath)
        For Each Sh In .Worksheets
            'ファイル名禁止文字列をアンダーバー(_)に置換
            strPdfFileName = replaceForbiddenCharactersFromFileName(Sh.Name, "_")
            
            'シート名をファイル名とした出力ファイルパスの作成
            strPdfFilePath = FolderPath & "\" & strPdfFileName & ".pdf"
            
            '対象シートをPDF出力
            Sh.ExportAsFixedFormat _
                Type:=xlTypePDF, FileName:=strPdfFilePath, OpenAfterPublish:=False
        Next
        .Close SaveChanges:=False
    End With
    On Error GoTo 0
End Sub


'--------------------------------------------------------
' ファイル名禁止文字置換関数
'--------------------------------------------------------
'［引数］
'   FileName    ：対象ファイル名の文字列
'   ReplaceSting：置換後文字列（既定：空の文字列）
'［戻り値］
'   ファイル名禁止文字を置換した文字列
'［作成日］2023/03/26　［更新日］2023/12/20
' https://excel.syogyoumujou.com/vba/conv_pdf.html
'--------------------------------------------------------
Private Function replaceForbiddenCharactersFromFileName(ByVal FileName As String, _
                                                        Optional ReplaceString As String = "") As String
    Dim varRemoveCharacters As Variant
    varRemoveCharacters = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    Dim i As Long
    For i = 0 To UBound(varRemoveCharacters)
        FileName = Replace$(FileName, varRemoveCharacters(i), ReplaceString, , , vbBinaryCompare)
    Next
    replaceForbiddenCharactersFromFileName = FileName
End Function

リクエスト 32024.08.06

「Excelファイルをシート指定で一括PDF化」
指定フォルダ内のExcelの指定したシートをPDFとして出力します。対象のExcelファイルは「xlsx」または「xls」です。
マクロ「OutputExcelSheetAsPDF」を実行しフォルダを選択すると処理が開始されます。指定したフォルダ内にはPDFフォルダが作成され、そのフォルダにPDFファイルが出力されます。
シートの指定は、次のコードの赤字箇所の数値を変更します。数値は左から数えたワークシートの番号になります（一番左のワークシートは「1」）。
PDFフォルダに、出力されるファイル名と同名のPDFファイルが既に存在した場合は、ファイルが上書きされますので気をつけてください。 

'-------------------------------------------------------------
' 指定フォルダのExcelをシート指定でPDF出力
'-------------------------------------------------------------
' https://excel.syogyoumujou.com/vba/conv_pdf.html
'-------------------------------------------------------------
Sub OutputExcelSheetAsPDF()
    '出力するExcelシートの番号設定(左から数えたシートの番号)
    Const SheetIndex As Long = 1 'シートの指定はこの数値を変更

    'フォルダの選択
    Dim strFolderPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then
            strFolderPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With

    'フォルダ存在確認
    If Dir(strFolderPath & "\PDF", vbDirectory) = "" Then
        MkDir strFolderPath & "\PDF" 'PDF用フォルダ作成
    End If

    'フォルダ内の全ファイルパス取得
    Dim colFilePath As Collection
    Set colFilePath = GetFilePath(strFolderPath)
    If colFilePath.Count = 0 Then Exit Sub 'ファイルパスがなければ終了
    
    'Excelファイルの指定シートをPDFで出力
    Application.ScreenUpdating = False
    Dim i As Long
    For i = 1 To colFilePath.Count
        If ThisWorkbook.Path <> colFilePath(i) Then
            Call MainProcessToOutputSheetAsPDF(strFolderPath, colFilePath(i), SheetIndex)
        End If
    Next
    Application.ScreenUpdating = True
End Sub


'------------------------------------------------------------
' 対象フォルダ内の全ファイルパス取得関数
'------------------------------------------------------------
'［引数］
'   FolderPath ：対象フォルダパス
'［戻り値］
'   Collectionオブジェクト　各要素にファイルパスが格納される
'------------------------------------------------------------
Private Function GetFilePath(ByVal FolderPath As String) As Collection
    Set GetFilePath = New Collection
    Dim c   As Long
    Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
    Dim F   As Object
    For Each F In FSO.GetFolder(FolderPath).Files
        c = c + 1
        GetFilePath.Add F.Path, CStr(c)
    Next
End Function


'------------------------------------------------------------
' Excelファイルの指定シートをPDF出力するメイン処理
'------------------------------------------------------------
'［引数］
'   FolderPath：対象フォルダパス
'   FilePath  ：対象ファイルパス
'   SheetIndex：シート番号（ワークシートを左から数えた数値）
'------------------------------------------------------------
Private Sub MainProcessToOutputSheetAsPDF(ByVal FolderPath As String, _
                                          ByVal FilePath As String, _
                                          Optional SheetIndex As Long = 1)
    '拡張子を確認
    Dim strFileName As String
    With CreateObject("Scripting.FileSystemObject")
        Select Case .GetExtensionName(FilePath)
        Case "xls", "xlsx"
            strFileName = Dir(FilePath) 'ファイル名取得
        Case Else
            Exit Sub 'Excel標準ブック以外は抜ける
        End Select
    End With
    
    'PDFとして出力
    Dim strPDFFilePath As String
    strPDFFilePath = FolderPath & "\PDF\" & Left$(strFileName, InStrRev(strFileName, ".")) & "pdf"
    With Workbooks.Open(FilePath)
        If 0 < SheetIndex And SheetIndex <= .Worksheets.Count Then '該当シートの存在確認
            .Worksheets(SheetIndex).ExportAsFixedFormat _
                Type:=xlTypePDF, FileName:=strPDFFilePath, OpenAfterPublish:=False
        End If
        .Close SaveChanges:=False
    End With
End Sub

リクエスト 42023.12.23

「複数ページに及ぶ印刷範囲の任意のページ間を一つのPDFファイルとして出力」
指定シート内で印刷範囲が複数のページに及ぶ場合に、任意のページ～ページを指定して一つにまとめたPDFファイルとして出力するマクロです。PDFファイルの出力は仮想プリンターの「Microsoft Print To PDF」を利用します。
※「Microsoft Print to PDF」は、Windows10から標準でインストールされています

ページの指定は「開始ページ」から「終了ページ」となるため。離れたページをまとめることには対応していません。

'---------------------------------------------------------------------------------
' 【実行マクロ】指定シートの複数の印刷範囲を一つのPDFファイルとして出力する
'---------------------------------------------------------------------------------
' 出力先は既定でデスクトップにしています。
' 印刷に関する情報の変更は定数の値を変更してください。
' 出力ファイル名には自動で出力日時が追加されます。
'［作成日］2023.12.23　［更新日］2023.12.24
' https://excel.syogyoumujou.com/vba/conv_pdf.html
'---------------------------------------------------------------------------------
Sub outputMultipleRangesAsOnePdfFile()
    '------------------------------------------------------------------------
    ' 定数
    '------------------------------------------------------------------------
    '【例】「伝票10%」シートの印刷範囲1～2ページを「サンプル*.pdf」として出力
    Const C_SHEETNAME    As String = "伝票10%"  '印刷対象シート名
    Const C_FROM         As Long = 1            '印刷開始ページ
    Const C_TO           As Long = 2            '印刷終了ページ
    Const C_PRTOFILENAME As String = "サンプル" '出力ファイル名

On Error Resume Next
    '------------------------------------------------------------------------
    ' 印刷シートの存在確認
    '------------------------------------------------------------------------
    Dim Sh As Worksheet
    Set Sh = ActiveWorkbook.Worksheets(C_SHEETNAME)
    If Sh Is Nothing Then
        MsgBox "印刷対象のシートが見つかりません", vbExclamation, "終了します"
        Exit Sub
    End If
On Error GoTo LBL_ERROR

    '------------------------------------------------------------------------
    ' 印刷範囲のページ数確認
    '------------------------------------------------------------------------
    Dim lngPages As Long
    lngPages = Sh.PageSetup.Pages.Count
   
    '------------------------------------------------------------------------
    ' 設定値確認
    '------------------------------------------------------------------------
    Dim strCheack As String
    If C_FROM < 1 Or lngPages < C_FROM Then
        strCheack = "印刷開始ページの設定が適切ではありません"
    ElseIf C_TO < 1 Or lngPages < C_TO Then
        strCheack = "印刷終了ページの設定が適切ではありません"
    End If
    If strCheack <> "" Then
        MsgBox strCheack, vbExclamation, "終了します"
        Exit Sub
    End If

    '------------------------------------------------------------------------
    ' デスクトップフォルダパス取得
    '------------------------------------------------------------------------
    Dim strFolderPath As String
    strFolderPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")

    '-----------------------------------------------------------------------
    ' フォルダ選択ダイアログ
    ' ※出力先フォルダを選択する場合は、次のコードをコメントアウトする
    '-----------------------------------------------------------------------
    'With Application.FileDialog(msoFileDialogFolderPicker)
    '    If .Show Then
    '        strFolderPath = .SelectedItems(1)
    '    Else
    '        Exit Sub
    '    End If
    'End With

    '---------------------------------------------------------------------
    ' フォルダパスに区切り文字を追加
    '---------------------------------------------------------------------
    strFolderPath = strFolderPath & Application.PathSeparator

    '---------------------------------------------------------------------
    ' 出力ファイル名作成
    '---------------------------------------------------------------------
    Dim strFileName As String
    strFileName = C_PRTOFILENAME & "_" & Format$(Now(), "yyyymmdd_HHMMSS") & ".pdf"

    'ファイル禁止文字の削除
    strFileName = replaceForbiddenCharactersFromFileName(strFileName)

    '---------------------------------------------------------------------
    ' 指定のシートを「Microsoft Print To PDF」で印刷する
    '---------------------------------------------------------------------
    If Not printoutMicrosoftToPdf(Sh, C_FROM, C_TO, strFolderPath & strFileName) Then
        Exit Sub 'エラーの場合は終了
    End If
                                
    MsgBox "PDFファイルを出力しました", vbInformation

    '---------------------------------------------------------------------
    ' ファイルを表示
    '---------------------------------------------------------------------
    Shell "C:\Windows\Explorer.exe " & strFolderPath & strFileName, vbNormalFocus
    Exit Sub
LBL_ERROR:
    MsgBox Err.Description, vbExclamation, "エラー番号：" & Err.Number
End Sub


'---------------------------------------------------------------------------------
' 指定のシートを「Microsoft Print To PDF」で印刷する
'---------------------------------------------------------------------------------
'［引数］
'   Sh              ：印刷対象シート
'   From            ：印刷を開始するページ番号を指定
'   To              ：印刷を終了するページ番号を指定
'   PrToFileName    ：引数 PrintTofile で True の場合に出力先ファイル名を指定
'［戻り値］
'   成功：True　失敗：Flase
'［作成日］2023.12.23　［更新日］2023.12.24
' https://excel.syogyoumujou.com/vba/conv_pdf.html
'---------------------------------------------------------------------------------
Function printoutMicrosoftToPdf(ByRef Sh As Worksheet, _
                                Optional ByVal lngFrom As Long = 1, _
                                Optional ByVal lngTo As Long = 1, _
                                Optional ByVal PrToFileName As String = "") As Boolean
On Error GoTo LBL_ERROR
    Call Sh.PrintOut(lngFrom, lngTo, 1, , "Microsoft Print to PDF", True, False, PrToFileName)
    printoutMicrosoftToPdf = True
    Exit Function
LBL_ERROR:
    MsgBox Err.Description, vbExclamation, "エラー番号：" & Err.Number
End Function


'---------------------------------------------------------------------------------
' ファイル名禁止文字置換関数
'---------------------------------------------------------------------------------
'［引数］
'   FileName    ：対象ファイル名の文字列
'   ReplaceSting：置換後文字列（既定：空の文字列）
'［戻り値］
'   ファイル名禁止文字を置換した文字列
'［作成日］2023/03/26　［更新日］2023/12/20
' https://excel.syogyoumujou.com/vba/conv_pdf.html
'---------------------------------------------------------------------------------
Function replaceForbiddenCharactersFromFileName(ByVal FileName As String, _
                                                Optional ReplaceString As String = "") As String
    Dim varRemoveCharacters As Variant
    varRemoveCharacters = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    Dim i As Long
    For i = 0 To UBound(varRemoveCharacters)
        FileName = Replace$(FileName, varRemoveCharacters(i), ReplaceString, , , vbBinaryCompare)
    Next
    replaceForbiddenCharactersFromFileName = FileName
End Function


リクエスト 52022.02.22

「Wordをページ指定で一括PDF化」

'+++ 宣言セクション +++
Const PAGES      As Boolean = True  'ページ指定：True　文書全体：False
Const START_PAGE As Long = 1        '開始ページ
Const END_PAGE   As Long = 3        '終了ページ


Sub Convert_WordToPDF() 'ワードをPDF化　ページ指定対応コード
    Dim strDirPath As String
    With Application.FileDialog(msoFileDialogFolderPicker) 'フォルダの選択
        If .Show = True Then strDirPath = .SelectedItems(1)
    End With
    If Len(strDirPath) = 0 Then Exit Sub
    If Dir(strDirPath & "\PDF", vbDirectory) = "" Then 'フォルダ存在確認
        MkDir strDirPath & "\PDF" 'フォルダ作成
    End If
    Call Search_Files(strDirPath)
End Sub


Private Sub Search_Files(ByVal Path As String)
    Dim strFile As String
    strFile = Dir(Path & "\" & "*.doc?") 'ファイル確認
    Application.ScreenUpdating = False
    Do Until strFile = ""
        If ThisWorkbook.FullName <> Path & "\" & strFile Then
            Call WordToPDF(Path, "\" & strFile)
        End If
        strFile = Dir() '次のファイル確認
    Loop
    Application.ScreenUpdating = True
End Sub


Private Sub WordToPDF(ByVal Path As String, ByVal Fn As String)
    Dim strFilePath  As String
    Dim objOffice    As Object
    strFilePath = Path & "\PDF" & Left$(Fn, InStrRev(Fn, ".")) & "pdf"
    Path = Path & Fn
    Select Case Get_Extension(Fn) 'ファイル名から拡張子取得
        Case "doc", "docx" 'Word97-2003,Word2007以降
            Set objOffice = CreateObject("Word.Application")
            With objOffice.Documents.Open(Path)
                If PAGES Then
                    .ExportAsFixedFormat OutputFileName:=strFilePath, _
                    ExportFormat:=17, Range:=3, From:=START_PAGE, To:=END_PAGE
                Else
                    .ExportAsFixedFormat OutputFileName:=strFilePath, _
                    ExportFormat:=17
                End If
                .Close
            End With
            objOffice.Quit
    End Select
End Sub


Private Function Get_Extension(ByVal Path As String) As String '拡張子取得
    Dim i As Long
    i = InStrRev(Path, ".", -1, vbTextCompare)
    If i = 0 Then Exit Function
    Get_Extension = Mid$(Path, i + 1)
End Function

リクエスト 62021.05.15

「PDFファイルに一括変換で、Wordを見えるようにした状態でPDF化し閉じる」
★のついている行でWordを見える状態にしています。 

Sub Convert_to_PDF() 'リクエストコード：Wordを見える状態でPDF化
    Dim strDirPath As String
    strDirPath = Search_Directory() 'フォルダの選択
    If Len(strDirPath) = 0 Then Exit Sub
    Call Make_Dir(strDirPath, "\PDF") 'フォルダ作成
    Call Search_Files(strDirPath)
End Sub


Private Function Search_Directory() As String 'フォルダの選択
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then Search_Directory = .SelectedItems(1)
    End With
End Function


Private Sub Make_Dir(ByVal Path As String, ByVal Dn As String)
    If Dir(Path & Dn, vbDirectory) = "" Then 'フォルダ存在確認
        MkDir Path & Dn 'フォルダ作成
    End If
End Sub


Private Sub Search_Files(ByVal Path As String)
    Dim strFile As String
    strFile = Dir(Path & "\" & "*.*") 'ファイル確認
    Application.ScreenUpdating = False
    Do Until strFile = ""
        If ThisWorkbook.FullName <> Path & "\" & strFile Then
            Call Conv_PDF(Path, "\" & strFile)
        End If
        strFile = Dir() '次のファイル確認
    Loop
    Application.ScreenUpdating = True
End Sub


Private Function Get_Extension(ByVal Path As String) As String '拡張子取得
    Dim i As Long
    i = InStrRev(Path, ".", -1, vbTextCompare)
    If i = 0 Then Exit Function
    Get_Extension = Mid$(Path, i + 1)
End Function


Private Sub Conv_PDF(ByVal Path As String, ByVal Fn As String)
    Dim filePath  As String
    Dim objOffice As Object
    filePath = Path & "\PDF" & Left$(Fn, InStrRev(Fn, ".")) & "pdf"
    Path = Path & Fn
    Select Case Get_Extension(Fn) 'ファイル名から拡張子取得
        Case "xls", "xlsx" 'Excel97-2003,Excel2007以降
            Set objOffice = Excel.Application
            With objOffice.Workbooks.Open(Path)
                .ExportAsFixedFormat Type:=xlTypePDF, _
                Filename:=filePath, Openafterpublish:=False
                .Close
            End With
        Case "doc", "docx" 'Word97-2003,Word2007以降
            Set objOffice = CreateObject("Word.Application")
            objOffice.Visible = True '★
            With objOffice.Documents.Open(Path)
                Call AppActivate(.Windows(1).Caption & " - Word") 
                Application.Wait Now() + TimeValue("00:00:01")    
                .ExportAsFixedFormat OutputFileName:=filePath, _
                ExportFormat:=17
                .Close
            End With
            objOffice.Quit
        Case "ppt", "pptx" 'PowerPoint97-2003,PowerPoint2007以降
            Set objOffice = CreateObject("PowerPoint.Application")
            With objOffice.Presentations.Open(Path)
                .SaveAs Filename:=filePath, FileFormat:=32
                .Close
            End With
            objOffice.Quit
    End Select
End Sub

関連記事：「PDFのデータをExcelに一括取り込み」

ページトップへ戻る

Excel 汎用コード

Copyright(C) 2009- 坂江 保 All Rights Reserved.