複数のExcelファイルから、同じシート名のものを集めて1つにまとめ、それをPDFに変換し、シート名をファイル名として保存するマクロ

複数のExcelファイルから、同じシート名のものを集めて1つにまとめ、それをPDFに変換し、シート名をファイル名として保存するマクロ portfolio

忘備録として

  • 複数のExcelファイルから、同じシート名のものを集めて1つにまとめ、それをPDFに変換し、シート名をファイル名として保存するマクロをAIを使って作成しました。
  • 新規でExcelファイルを作成、開発⇒VisualBasic⇒ペースト⇒実行
  • シート名の変更は、 ‘ コピーするシートの名前を指定 sheetName = “ここを変更”
  • 11ファイルくらいまで問題なく結合できていましたが、それ以上はテストしていません。
  • 自己責任で使用をお願いします。
Sub 結合してPDFに出力して削除するマクロ()
    Dim mainWorkbook As Workbook
    Dim sourceWorkbook As Workbook
    Dim ws As Worksheet
    Dim mainSheet As Worksheet
    Dim filePaths As Variant
    Dim filePath As Variant
    Dim sheetName As String
    Dim savePath As String
    Dim pdfPath As String

    ' メインのワークブックを設定
    Set mainWorkbook = ThisWorkbook
    
    ' メインのシートを設定
    Set mainSheet = mainWorkbook.Sheets("結合シート")
    
    ' 取り込むファイルを選択
    filePaths = Application.GetOpenFilename(FileFilter:="Excelファイル (*.xls; *.xlsx), *.xls; *.xlsx", Title:="ファイルを選択してください", MultiSelect:=True)
    
    If Not IsArray(filePaths) Then
        ' ファイルが選択されなかった場合の処理
        Exit Sub
    End If
    
    If UBound(filePaths) < LBound(filePaths) Then
        ' 空の配列の場合の処理
        Exit Sub
    End If
    
    ' ユーザーに保存先のフォルダを選択させる
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            savePath = .SelectedItems(1)
        Else
            ' フォルダが選択されなかった場合の処理
            Exit Sub
        End If
    End With
    
    ' 取り込むファイルごとにループ
    For Each filePath In filePaths
        ' 新しいワークブックを開く
        Set sourceWorkbook = Workbooks.Open(filePath)
        
        ' コピーするシートの名前を指定
        sheetName = "アーモンド"
        
        ' コピー元のシートが存在する場合
        If WorksheetExists(sourceWorkbook, sheetName) Then
            ' コピー
            sourceWorkbook.Sheets(sheetName).Copy Before:=mainSheet
        End If
        
        ' ワークブックを閉じる（保存しない）
        sourceWorkbook.Close False
    Next filePath
    
    ' PDF出力先のパスを指定（ファイル名にコピーするシートの名前を使う）
    pdfPath = savePath & "\" & sheetName & ".pdf"
    
    ' 結合したファイルをPDFに出力
    mainWorkbook.ExportAsFixedFormat Type:=xlTypePDF, fileName:=pdfPath, Quality:=xlQualityStandard
    
    ' メインのワークブックを閉じる（保存しない）
    mainWorkbook.Close False
    
    ' 結合したxlsmファイルを削除
    Kill mainWorkbook.FullName
End Sub

Function WorksheetExists(wb As Workbook, wsName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = wb.Sheets(wsName)
    On Error GoTo 0
    WorksheetExists = Not ws Is Nothing
End Function

コメント