XL 2013 Diviser classeur en plusieur fichier et les enregistrer en PDF

'Bonjour

Option Explicit
Public iTotal_file As Long
Public iCount_file As Long
Sub division_fichier()


  
    Call sFreezeExcelDebut
    
    Call sSplitPN(ThisWorkbook)
    
    Call sFreezeExcelFin

End Sub

Private Sub sSplitPN(pwbkAppelant As Workbook)
If Not gbDebug Then On Error GoTo ErrorHandler
    Dim sFilePath, sFilePathXLS, sFilePathPDF As String
    Dim sFolderName As String
    Dim ws As Worksheet
    Dim iCountRow As Long
    Dim i As Integer
    Dim tab_supplier() As String
    
    Set ws = pwbkAppelant.Worksheets("PN List")
    iCountRow = ws.UsedRange.Rows.Count
    
    sFilePath = pwbkAppelant.Path & "\"
    sFolderName = fsCleanPath(pwbkAppelant, Now() & "_ListPN")
    
    '1 - Creation of the folder
    sFilePathXLS = sFilePath + sFolderName + "\XLS"
    Call fbCreateFolder(pwbkAppelant, sFilePathXLS)

    sFilePathPDF = sFilePath + sFolderName + "\PDF"
    Call fbCreateFolder(pwbkAppelant, sFilePathPDF)
    
    MsgBox "Folder created"
    
    '2 - split of the PN List according to the supplier
    If Not fbSupprDoub(pwbkAppelant, ws, tab_supplier(), 1, 16) Then Exit Sub
    iTotal_file = UBound(tab_supplier())
    iCount_file = 0
    Progression.Show vbModeless
    Progression.Repaint
    
    For i = LBound(tab_supplier) To UBound(tab_supplier) - 1
        Call fbSplitPN_sub(pwbkAppelant, ws, tab_supplier(i))
        Call fbSaveXLS(pwbkAppelant, tab_supplier(i), sFilePathXLS, sFilePathPDF)
    Next i
    '3 - Save the new file as pdf
    
    MsgBox "File creation finished, total files created :" & vbCrLf _
        & iCount_file & " / " & iTotal_file, _
        vbOKOnly, _
        "Progression"

    Unload Progression
    
    Exit Sub
ErrorHandler:
    sGestionErreur pwbkAppelant, "sSplitPN"
End Sub

Private Function fbSplitPN_sub(pwbkAppelant As Workbook, pws As Worksheet, psSupplier As String) As Boolean
If Not gbDebug Then On Error GoTo ErrorHandler
    Dim i, j, iRows, iRowSupplier As Long
    Dim wshtTmp, wsTemplate As Worksheet
    
    'Create new worksheet
    Set wsTemplate = pwbkAppelant.Worksheets("template")
    wsTemplate.Copy After:=pwbkAppelant.Worksheets(pwbkAppelant.Sheets.Count)
    
    Set wshtTmp = pwbkAppelant.Worksheets(pwbkAppelant.Sheets.Count)
    wshtTmp.Name = "PN supplier"
    
    iRows = pws.UsedRange.Rows.Count
    
    'Copy row to new worksheet
    iRowSupplier = 2
    
    
    'Pour rajouter des colonnes, dupliquer la ligne suivante et l'inclure dans le if:
    'wshtTmp.Cells(iRowSupplier, 1) = pws.Cells(i, 1)
    
    For i = 2 To iRows
        If pws.Cells(i, 16) = psSupplier Then
            wshtTmp.Cells(iRowSupplier, 1) = pws.Cells(i, 1) 'PN
            wshtTmp.Cells(iRowSupplier, 2) = pws.Cells(i, 2) 'Description
            wshtTmp.Cells(iRowSupplier, 3) = pws.Cells(i, 3) 'Supplier
            wshtTmp.Cells(iRowSupplier, 4) = pws.Cells(i, 4)
            wshtTmp.Cells(iRowSupplier, 5) = pws.Cells(i, 5)
            wshtTmp.Cells(iRowSupplier, 6) = pws.Cells(i, 6)
            wshtTmp.Cells(iRowSupplier, 7) = pws.Cells(i, 7)
            wshtTmp.Cells(iRowSupplier, 8) = pws.Cells(i, 8)
            wshtTmp.Cells(iRowSupplier, 9) = pws.Cells(i, 9)
            wshtTmp.Cells(iRowSupplier, 10) = pws.Cells(i, 10)
            wshtTmp.Cells(iRowSupplier, 11) = pws.Cells(i, 11)
            wshtTmp.Cells(iRowSupplier, 12) = pws.Cells(i, 12)
            wshtTmp.Cells(iRowSupplier, 13) = pws.Cells(i, 13)
            wshtTmp.Cells(iRowSupplier, 14) = pws.Cells(i, 14)
            wshtTmp.Cells(iRowSupplier, 15) = pws.Cells(i, 15)
            wshtTmp.Cells(iRowSupplier, 16) = pws.Cells(i, 16)
            iRowSupplier = iRowSupplier + 1
        End If
    Next i
    'adjust the width of each column
    For j = 1 To wshtTmp.UsedRange.Columns.Count
        wshtTmp.Columns(j).AutoFit
    Next j
    Exit Function
ErrorHandler:
    sGestionErreur pwbkAppelant, "fbSplitPN_sub"
End Function

Private Function fbSaveXLS(pwbkAppelant As Workbook, psSupplierName As String, ByVal psPathXLS As String, ByVal psPathPDF As String) As Boolean
If Not gbDebug Then On Error GoTo ErrorHandler
    Dim aShtList
    Dim sFileName As String
    Dim wsSupplier As Worksheet
    Dim wbkReception As Workbook
    Dim wsReception As Worksheet
    
    Set wsSupplier = pwbkAppelant.Worksheets("PN supplier")
    
    sFileName = "PN_List_" & psSupplierName & "_2018"
    sFileName = fsCleanPath(pwbkAppelant, sFileName) & ".xls"
    
    Application.DisplayAlerts = False
    
    wsSupplier.Select
    wsSupplier.Copy
    
    'Save as XLS
    ChDir psPathXLS
    Set wbkReception = ActiveWorkbook
    Set wsReception = wbkReception.Sheets(1)
    
    wsReception.Name = "PN List"
    
    wbkReception.SaveAs Filename:= _
        sFileName _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    wsReception.Select
        
    'Save as PDF
    Call fbConvertPDFsub(wbkReception, wsReception, psSupplierName, psPathPDF)
    
    wbkReception.Close savechanges:=True
    
    wsSupplier.Delete
    Application.DisplayAlerts = True
    
    fbSaveXLS = True
    iCount_file = iCount_file + 1
    Progression.Count_created.Caption = iCount_file
    Progression.Repaint
    
    Exit Function
ErrorHandler:
    sGestionErreur pwbkAppelant, "fbSaveXLS"
End Function

Private Function fbConvertPDFsub(pwbAppelant As Workbook, pwsWshtProcess As Worksheet, psSupplier As String, psPath As String) As Boolean
If Not gbDebug Then On Error GoTo ErrorHandler
    'ENREGISTRE LE PDF
    
    Dim wsPN As Worksheet
    Dim sFilePath As String
    Dim sfilenamePdf As String
    Dim PDFName As String
    'Dim sSupplierName As String
    Dim iLastRow As Integer
    Dim sPrintRange As String
      
    'Set wsDocPlan = pwbAppelant.ActiveSheet
    
    'sSupplierName = pwbAppelant.Name
    'MsgBox sProcessName
    
    'sFilePath = pwbAppelant.Path & "\"
    sfilenamePdf = "PN_List_" & psSupplier & "_2018"
    sfilenamePdf = fsCleanPath(pwbAppelant, sfilenamePdf) & ".pdf"
    PDFName = psPath & "\" & sfilenamePdf
    
    iLastRow = pwsWshtProcess.UsedRange.Rows.Count
    sPrintRange = "A1:C" & iLastRow
    
    With pwsWshtProcess.PageSetup
        .Orientation = xlLandscape
        .PrintArea = sPrintRange
        '.PrintTitleRows = "$3:$3"
        .FitToPagesWide = 1
    End With
    
    pwsWshtProcess.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=PDFName, _
        Quality:=xlQualityStandard, _
        IgnorePrintAreas:=False
        
    fbConvertPDFsub = True
    
    Exit Function
ErrorHandler:
    sGestionErreur pwbAppelant, "fbConvertPDFsub"
End Function