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

PDFファイルに一括変換

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


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

サンプルコード2019.01/20 更新:2023.03.10

コードの貼り付け場所

'------------------------------------------------------------
' 指定フォルダの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 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化されたファイルが作成されていきます。

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

リクエストコード 12023.01.21

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 End With End Sub

リクエストコード 22022.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


リクエストコード 32021.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


ページトップへ戻る

Excel 汎用コード



Word 汎用コード

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