【知らなくても使える】Excelのシート毎に分けてPDF出力するアドイン（Excel VBA）

Option Explicit

'-----（メッセージ）-------------------
Private Const Msg1 = "PDfファイルを保存するフォルダを選択してください｡"
Private Const Msg2 = "指定したシートが存在しません。"
'---------------------------------------

Dim TgtSheetNm As String
Dim TgtFileNm As String

'===================================
'全シートを対象にして1つのPDFに保存した際の処理
'===================================
Sub allSheetForOnePDF_click(control As IRibbonControl)

    Dim sheetCnt As Long: sheetCnt = ActiveWorkbook.Worksheets.Count
    Dim sheetNmArray() As String        'Excelブック内のシート名称（配列）
    ReDim sheetNmArray(1 To sheetCnt)
    Dim visShtCnt As Long               '表示中のシート数
    Dim i As Long
    
    '全てのシートを対象にするため配列に全シート名を格納する
    For i = 1 To sheetCnt
        If ActiveWorkbook.Sheets(i).Visible = True Then
            visShtCnt = visShtCnt + 1
            sheetNmArray(visShtCnt) = ActiveWorkbook.Sheets(i).Name
        End If
    Next i
    
    ReDim Preserve sheetNmArray(1 To visShtCnt)
    
    ''PDFファイル保存処理
    Call savePdf(sheetNmArray, 1)
    
End Sub

'===================================
'指定シートを対象にして1つのPDFに保存した際の処理
'===================================
Sub tgtSheetForOnePDF_click(control As IRibbonControl)

    Dim sheetCnt As Long: sheetCnt = ActiveWorkbook.Worksheets.Count
    Dim objSheet As Worksheet

    Dim sheetNmArray() As String
    ReDim sheetNmArray(1 To sheetCnt)
    Dim matchCnt As Long                '対象のシート名と一致するシート数
    
    'Excelファイル内で条件に一致するシートのみシート名を配列に格納する
    For Each objSheet In ActiveWorkbook.Worksheets
      
        If objSheet.Name Like TgtSheetNm Then
            If ActiveWorkbook.Sheets(objSheet.Name).Visible = True Then
                matchCnt = matchCnt + 1
                sheetNmArray(matchCnt) = objSheet.Name
            End If
        End If
      
    Next
    
    If matchCnt <> 0 Then
        ReDim Preserve sheetNmArray(1 To matchCnt)
    Else
        MsgBox Msg2
        Exit Sub
    End If
    
    ''PDFファイルの保存処理
    Call savePdf(sheetNmArray, 1)
    
End Sub

'===================================
'全シートを対象にして複数のPDFに保存した際の処理
'===================================
Sub allSheetForSomePDF_click(control As IRibbonControl)

    Dim sheetCnt As Long: sheetCnt = ActiveWorkbook.Worksheets.Count
    Dim sheetNmArray() As String        'Excelブック内のシート名称（配列）
    ReDim sheetNmArray(1 To sheetCnt)
    Dim visShtCnt As Long               '表示中のシート数
    Dim i As Long
    
    '全てのシートを対象にするため配列に全シート名を格納する
    For i = 1 To sheetCnt
        If ActiveWorkbook.Sheets(i).Visible = True Then
            visShtCnt = visShtCnt + 1
            sheetNmArray(visShtCnt) = ActiveWorkbook.Sheets(i).Name
        End If
    Next i
    
    ReDim Preserve sheetNmArray(1 To visShtCnt)
    
    ''PDFファイルの保存処理
    Call savePdf(sheetNmArray, 2, TgtFileNm)
    
End Sub

'-------------------------
'PDFファイルの保存処理
'　引数：sheetNmArray（対象のシート名が入った配列）
'      　processCd（1：一つのPDFファイルで出力、2：複数PDFファイルで出力）
'　　　　opFileNm（ファイル名の最初に付ける名称）※複数PDFファイルで出力する処理のみ
'-------------------------
Sub savePdf(sheetNmArray() As String, processCd As Long, Optional opFileNm As String = "")
    
    Dim selSheetNm As String
    selSheetNm = ActiveSheet.Name
    
    Dim objFileSys As Object
    Dim noExtensionFileName As String
    Dim fileName As Variant
    Dim sheetNm As Variant
    
    'ファイルシステムを扱うオブジェクトを作成
    Set objFileSys = CreateObject("Scripting.FileSystemObject")
     
    '拡張子無しのファイル名を取得
    noExtensionFileName = objFileSys.GetBaseName(ActiveWorkbook.FullName)
    
    '一つのPDFファイルに保存する場合の処理
    If processCd = 1 Then
    
        'PDFファイルの保存先とファイル名称を指定する
        fileName = Application.GetSaveAsFilename(InitialFileName:=noExtensionFileName, FileFilter:="PDF,*.pdf")
        If fileName <> False Then
        
            Worksheets(sheetNmArray).Select
            
            'PDF出力処理
            ActiveSheet.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                fileName:=fileName
            
        End If
        
    '複数PDFファイルに保存する場合の処理
    Else

        Dim folderPath As Variant
        
        With Application.FileDialog(msoFileDialogFolderPicker)
            .AllowMultiSelect = False
    
            .Title = Msg1
            If .Show = True Then
                folderPath = .SelectedItems(1)
            Else
                Exit Sub
            End If
        End With
        
        For Each sheetNm In sheetNmArray
            
            If opFileNm <> "" Then
                fileName = folderPath & "\" & opFileNm & "_" & sheetNm & ".pdf"
            Else
                fileName = folderPath & "\" & sheetNm & ".pdf"
            End If
            
            Worksheets(sheetNm).Select
            
            'PDF出力処理
            ActiveSheet.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                fileName:=fileName
                    
        Next
    End If
    
    Worksheets(selSheetNm).Select
        
End Sub

'-------------------------
'シート名に変更があった際の処理
'-------------------------
Sub onChangeSheetNm(control As IRibbonControl, text As String)
    TgtSheetNm = text
End Sub

'-------------------------
'シート名に変更があった際の処理
'-------------------------
Sub onChangeFileNm(control As IRibbonControl, text As String)
    TgtFileNm = text
End Sub

'-------------------------
'シート名を取得する際の処理
'-------------------------
Sub getSheetNm(control As IRibbonControl, ByRef returnValue)
    '処理なし
End Sub

'-------------------------
'ファイル名を取得する際の処理
'-------------------------
Sub getFileNm(control As IRibbonControl, ByRef returnValue)
    '処理なし
End Sub