Sub ConvertAllXlsToPdf() Dim folderPath As String Dim outputFolder As String Dim useSourceFolder As Boolean ' C1とC2セルからパスを取得 folderPath = ThisWorkbook.Worksheets(1).Range("C1").Value outputFolder = ThisWorkbook.Worksheets(1).Range("C2").Value ' C1が空の場合はエラー If folderPath = "" Then MsgBox "C1セル(検索元フォルダ)にパスを入力してください。", vbExclamation Exit Sub End If ' フォルダが存在するか確認 Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") If Not fso.FolderExists(folderPath) Then MsgBox "C1セルのフォルダが存在しません: " & folderPath, vbExclamation Exit Sub End If ' C2が空または存在しない場合は各ファイルと同じフォルダに出力 If outputFolder = "" Then useSourceFolder = True MsgBox "出力先フォルダが指定されていないため、各Excelファイルと同じフォルダに出力します。", vbInformation ElseIf Not fso.FolderExists(outputFolder) Then MsgBox "C2セルのフォルダが存在しないため、各Excelファイルと同じフォルダに出力します。", vbInformation useSourceFolder = True Else useSourceFolder = False End If ' 再帰的に検索・変換 Application.ScreenUpdating = False Application.DisplayAlerts = False Call SearchAndConvert(folderPath, outputFolder, useSourceFolder) Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "変換完了しました!", vbInformation Set fso = Nothing End Sub
' 再帰的にフォルダを検索する関数 Sub SearchAndConvert(ByVal folderPath As String, ByVal outputFolder As String, ByVal useSourceFolder As Boolean) Dim fso As Object Dim folder As Object Dim subFolder As Object Dim file As Object Set fso = CreateObject("Scripting.FileSystemObject") Set folder = fso.GetFolder(folderPath) ' 現在のフォルダ内のファイルを処理 For Each file In folder.Files If LCase(fso.GetExtensionName(file.Path)) = "xls" Or _ LCase(fso.GetExtensionName(file.Path)) = "xlsx" Or _ LCase(fso.GetExtensionName(file.Path)) = "xlsm" Then Call ConvertFileToPdf(file.Path, outputFolder, useSourceFolder) End If Next file ' サブフォルダを再帰的に処理 For Each subFolder In folder.SubFolders Call SearchAndConvert(subFolder.Path, outputFolder, useSourceFolder) Next subFolder Set fso = Nothing End Sub
' 個別ファイルをPDF化する関数 Sub ConvertFileToPdf(ByVal filePath As String, ByVal outputFolder As String, ByVal useSourceFolder As Boolean) Dim wb As Workbook Dim ws As Worksheet Dim fileName As String Dim pdfName As String Dim fso As Object Dim targetFolder As String On Error Resume Next Set fso = CreateObject("Scripting.FileSystemObject") fileName = fso.GetBaseName(filePath) ' 拡張子なしのファイル名 ' 出力先フォルダを決定 If useSourceFolder Then ' Excelファイルと同じフォルダに出力 targetFolder = fso.GetParentFolderName(filePath) Else ' 指定された出力先フォルダに出力 targetFolder = outputFolder End If ' ファイルを開く Set wb = Workbooks.Open(filePath, ReadOnly:=True) If Not wb Is Nothing Then ' 各シートをPDF化 For Each ws In wb.Worksheets pdfName = targetFolder & "\" & fileName & "_" & ws.Name & ".pdf" ' 無効な文字を置換 Dim cleanFileName As String cleanFileName = fileName & "_" & ws.Name cleanFileName = Replace(cleanFileName, "/", "_") cleanFileName = Replace(cleanFileName, ":", "_") cleanFileName = Replace(cleanFileName, "*", "_") cleanFileName = Replace(cleanFileName, "?", "_") cleanFileName = Replace(cleanFileName, """", "_") cleanFileName = Replace(cleanFileName, "<", "_") cleanFileName = Replace(cleanFileName, ">", "_") cleanFileName = Replace(cleanFileName, "|", "_") pdfName = targetFolder & "\" & cleanFileName & ".pdf" ws.ExportAsFixedFormat Type:=xlTypePDF, _ fileName:=pdfName, _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=False Next ws wb.Close SaveChanges:=False End If Set wb = Nothing Set fso = Nothing On Error GoTo 0 End Sub
If LCase(fso.GetExtensionName(file.Path)) = "xls" Or _ LCase(fso.GetExtensionName(file.Path)) = "xlsx" Or _ LCase(fso.GetExtensionName(file.Path)) = "xlsm" Then Call ConvertFileToPdf(file.Path, outputFolder, useSourceFolder) End If