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

soffianne · 17 Octobre 2019

Bonjour,

J'ai un fichier qui comporte des informations pour plusieur fournisseurs.

j'aimerais diviser ce fichier en fonction de la colone "supplier".

J'ai donc utilisé la maccro suivante afin de créer un fichier par fournisseur et de les enregistrer en vesrion Excel et PDF.

Malheuresement, un message d'erreur s'affiche chaque fois que je lance la maccro alors que cette dernière fonctionne parfaitement sur un autre fichier.

------------------------------------------------------------------------------------------------------------------

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

soffianne · 17 Octobre 2019

Si quelqu'un a une solution ce serait génial, merci d'avance.

xUpsilon · 17 Octobre 2019

Bonjour,

Ton code est vraiment long, sans le mettre sous la forme

VB:

'Bonjour

c'est un enfer à lire ... Penses à utiliser les balises </>
Sinon, quand l'erreur s'affiche, quelle ligne pose problème, et quelle erreur est-ce ?

Bonne continuation

soffianne · 17 Octobre 2019

VB:

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

soffianne · 17 Octobre 2019

L'erreur qui s'affiche est "erreur de compilation, Sub ou function non définie."

kiki29 · 17 Octobre 2019

soffianne · 28 Octobre 2019

merci pour le partage.

Etant donné que la maccro que j'ai utilisé est vraiment complexe et donc difficilement corrigeable, je suis également ouvert à toutes proposition de maccros qui me permette de diviser ma feuille excel en plusieurs fichiers.

Comme je l'ai dit plus haut j'aimerais avoir un fichier excel par "supplier".

Je vous remercie par avance.

xUpsilon · 28 Octobre 2019

Re,

Où est ta fonction sFreezeExcelDebut ?

Bonne continuation

soffianne · 28 Octobre 2019

Re,

Justement, ce n'est pas moi qui a rédigé la maccro, elle m'a été envoyé et je ne sais pas à quoi correspondent "sFreezeExcelDebut" et sFreezeExcelFin".

xUpsilon · 28 Octobre 2019

Call ____ veut dire que tu appelles la macro ____.
Donc ici on appelle la fonction sFreezeExcelDebut, sauf qu'elle n'est pas dans ton code, donc forcément ça ne fonctionne pas

C'est comme si tu tournais la clé dans ta voiture, que ça appelle le moteur pour qu'il démarre, sauf qu'il y a pas de moteur dans ta voiture : bah ça va pas marcher super bien quoi

Bonne continuation

soffianne · 28 Octobre 2019

Je suis totalement d'accord avec toi, mais je t'invite à regarder le fichier que je vais mettre en pièce jointe (c'est celui sur lequel je me suis calqué).
La maccro utilisé est éxactement la méme que celle que j'ai utilisé donc elle fait appel aux fonctions "sFreezeExcelDebut" et "sFreezeExcelFin" sans les mentionner dans le code. et pourtant la maccro fonctionne parfaitement.

C'est la raison pour laquelle je suis un peu perdu avec ce code....

xUpsilon · 28 Octobre 2019

Re,

Bien sur que si qu'elle y est haha.
Regarde bien, la fonction qui appelle sFreezeExcelDebut est une Public, ce qui veut dire qu'elle est valable pour tout le document, pas uniquement localement dans ce module.
Maintenant regarde dans le deuxième module de ton classeur, tu vas trouver toutes les fonctions donc tu as besoin pour faire fonctionner ton classeur.

Bonne continuation

soffianne · 28 Octobre 2019

super, merci !

Je débute tout juste les maccros du coup je n'ai pas pensé à regarder dans les autres modules.

Bonne continuation à toi aussi.

Effectuez une recherche sur Excel Downloads...

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

soffianne

XLDnaute Nouveau

Pièces jointes

soffianne

XLDnaute Nouveau

xUpsilon

XLDnaute Accro

soffianne

XLDnaute Nouveau

soffianne

XLDnaute Nouveau

Pièces jointes

kiki29

XLDnaute Barbatruc

Pièces jointes

soffianne

XLDnaute Nouveau

xUpsilon

XLDnaute Accro

soffianne

XLDnaute Nouveau

xUpsilon

XLDnaute Accro

soffianne

XLDnaute Nouveau

Pièces jointes

xUpsilon

XLDnaute Accro

soffianne

XLDnaute Nouveau

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums