【マクロ配布】シート毎PDF変換について解説

Sub EXCELファイルPDF化_シート毎() 'フォルダのEXCELファイルの一括変換
        
    Dim Button, T, i, L As Integer
    Dim OpenExcelFileName, ExcelFileName, ExcelFilePath, ExFileName As String
    
    '確認メッセージを無効化します。
    Application.DisplayAlerts = False
    
    
    Button = MsgBox("EXCELファイルの一括PDF変換を行いますか？", vbYesNo + vbQuestion, "確認")

 If Button = vbYes Then
            
            OpenExcelFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")  'ダイアログを表示取り込むフォルダーにあるファイルを選択します。
            
            If OpenExcelFileName <> "False" Then
                ExcelFileName = Dir(OpenExcelFileName)  '指定したファイルパスからファイル名を代入します。
                ExcelFilePath = Replace(OpenExcelFileName, ExcelFileName, "")  '指定したファイルパスを指定します。（ファイルパスからファイル名を取り除く）
               
                MsgBox ExcelFilePath & "この選択フォルダからPDFに変換します。"
            Else
                MsgBox "キャンセルされました"
                Exit Sub  'キャンセルでプログラムを終了します。
                
            End If
        
            ExFileName = Dir(ExcelFilePath & "*.xls?")  '指定したフォルダーから一件目のEXCELファイルを指定します。
 
            
            Do While ExFileName <> ""    '読み込むファイルがなくなるまで繰り返す。
                
                
                Workbooks.Open FileName:=ExcelFilePath & ExFileName, ReadOnly:=True, UpdateLinks:=0  'EXCELファイルを読み取り専用で読み込む
            Call ワークシートごとにPDFに変換
            
            ActiveWindow.Close  '読み込んだファイルを閉じます。
            
            ExFileName = Dir() '次のファイルを指定する。
 
            Loop
            
           
    Else
        MsgBox "処理を中断します"
        Exit Sub
    End If
    

If OpenExcelFileName <> "False" Then

ExcelFileName = Dir(OpenExcelFileName) '指定したファイルパスからファイル名を代入します。
ExcelFilePath = Replace(OpenExcelFileName, ExcelFileName, "") '指定したファイルパスを指定します。（ファイルパスからファイル名を取り除く）

 ExFileName = Dir(ExcelFilePath & "*.xls?")  '指定したフォルダーから一件目のEXCELファイルを指定します。
 
            
            Do While ExFileName <> ""    '読み込むファイルがなくなるまで繰り返す。
                
                
                Workbooks.Open FileName:=ExcelFilePath & ExFileName, ReadOnly:=True, UpdateLinks:=0  'EXCELファイルを読み取り専用で読み込む

Call ワークシートごとにPDFに変換
            
            ActiveWindow.Close  '読み込んだファイルを閉じます。
            
            ExFileName = Dir() '次のファイルを指定する。
 

Sub ワークシートごとにPDFに変換()

Dim i As Long
Dim sh As Worksheet
Dim N As Long
Dim Str As String
Dim suu As Long
Dim sha  As Long

'高速化コード
 Application.ScreenUpdating = False
 
    '全シートをループ
    For Each sh In Sheets
    
       '選択したシートが非表示の時、削除
       If sh.Visible = xlSheetHidden Then
           sh.Delete
       Else
       '上記以外の時、カウント
           N = N + 1
       End If
       
    Next sh
 
    'シート数が1より大きい時
    If N > 1 Then
        'シート1のみ選択
        Worksheets(1).Select Replace:=True
        'シート2も選択
        Worksheets(2).Select Replace:=False
        'シート1のみ選択
        Worksheets(1).Select Replace:=True
        'シート2のみ選択(デフォルト)
        Worksheets(2).Select
        
    End If

    For i = 1 To Worksheets.Count
        'シートが表示されているとき（非表示ではないとき）
            If Sheets(i).Visible Then
            
            If WorksheetFunction.CountA(Sheets(i).UsedRange) = 0 And Sheets(i).Shapes.Count = 0 Then
            Else
            
    Str = Right("0000" & i, 3)
    Worksheets(i).ExportAsFixedFormat Type:=xlTypePDF, _
    FileName:=Left(ActiveWorkbook.Name, InStr(ActiveWorkbook.Name, ".xl") - 1) & "_" & Str & "_" & _
    Worksheets(i).Name & "_" & i, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, openafterpublish:=False
    
    End If
    
    End If
    
    Next i
Application.ScreenUpdating = True '高速化コード

End Sub

'上記以外の時、カウント
           N = N + 1

 'シート数が1より大きい時
    If N > 1 Then
　　　　'シート1のみ選択
        Worksheets(1).Select Replace:=True
        'シート2も選択
        Worksheets(2).Select Replace:=False
        'シート1のみ選択
        Worksheets(1).Select Replace:=True
        'シート2のみ選択(デフォルト)
        Worksheets(2).Select
        
    End If

If WorksheetFunction.CountA(Sheets(i).UsedRange) = 0 And Sheets(i).Shapes.Count = 0 Then
Else