VBA Gestion d'erreur lors d'ouverture de fichiers

Le 24/08/2021 à 15:20

Bonjour,

J'ai piqué ce code sur internet ICI

Le but étant d'avoir une mini application pour convertir des Excel en PDF.

J'ai 2 problèmes:

Parfois sans trop de raison VBA n'arrive pas à ouvrire le fichier

image

Etant donné que c'est assez rare sur les dizaines de fichiers à traiter, j'aimerais en cas d'erreur mémoriser le nom du fichier et passer à la suite pour à la fin afficher les fichiers qui n'ont pas fonctionnés et les convertir manuellement

Je suis vraiment pas a l'aise avec la gestion d'erreur..

On Error Resume next and memoire = xbwname

Vous avez compris quoi...

Merci d'avance pour votre aide =)

Sub ExcelSaveAsPDF(entete As Boolean)
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
'Updateby Extendoffice
    Dim strPath As String
    Dim xStrFile1, xStrFile2 As String
    Dim xWbk As Workbook
    Dim xSFD, xRFD As FileDialog
    Dim xSPath As String
    Dim xRPath, xWBName As String
    Dim xBol As Boolean
    Set xSFD = Application.FileDialog(msoFileDialogFolderPicker)
    With xSFD
    .Title = "Please select the folder contains the Excel files you want to convert:"
    .InitialFileName = "C:\"
    End With
    If xSFD.Show <> -1 Then Exit Sub
    xSPath = xSFD.SelectedItems.Item(1)
    'Set xRFD = Application.FileDialog(msoFileDialogFolderPicker)
    'With xRFD
    '.Title = "Please select a destination folder to save the converted files:"
    '.InitialFileName = "C:\"
    'End With
    'If xRFD.Show <> -1 Then Exit Sub
    xRPath = xSPath & "\"
    strPath = xSPath & "\"
    xStrFile1 = Dir(strPath & "*.*")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Do While xStrFile1 <> ""
        xBol = False
        If Right(xStrFile1, 3) = "xls" Then
            Set xWbk = Workbooks.Open(Filename:=strPath & xStrFile1)
            n = 0
            If entete = True Then
                For Each feuil In xWbk.Worksheets
                If n > 0 Then feuil.Visible = False
                n = n + 1
                Next feuil
            End If
            xbwname = Replace(xStrFile1, ".xls", "_pdf")
            xBol = True
        ElseIf Right(xStrFile1, 4) = "xlsx" Then
            Set xWbk = Workbooks.Open(Filename:=strPath & xStrFile1)
            n = 0
            If entete = True Then
                For Each feuil In xWbk.Worksheets
                If n > 0 Then feuil.Visible = False
                n = n + 1
                Next feuil
            End If
            xbwname = Replace(xStrFile1, ".xlsx", "_pdf")
            xBol = True
        ElseIf Right(xStrFile1, 4) = "xlsm" Then
            Set xWbk = Workbooks.Open(Filename:=strPath & xStrFile1)
            n = 0
            If entete = True Then
                For Each feuil In xWbk.Worksheets
                If n > 0 Then feuil.Visible = False
                n = n + 1
                Next feuil
            End If
            xbwname = Replace(xStrFile1, ".xlsm", "_pdf")
            xBol = True
        End If
        If xBol Then
            xWbk.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xRPath & xbwname & ".pdf"
            xWbk.Close SaveChanges:=False
       End If
        xStrFile1 = Dir
    Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.AskToUpdateLinks = True
End Sub
Le 24/08/2021 à 15:35

Pour éviter l'erreur il faudrait peut être s'assurer que 'xSFD.SelectedItems' soit supérieur à 0

Sinon pour récupérer les fichiers en erreurs tu peux utiliser la fonction 'ERR' et en fonction de celle ci alimenter un tableau avec les noms de fichiers en question, puis bien penser à faire ERR.clear pour le fichier suivant a fin de supprimer l'erreur en mémoire.

x=1

On error resume Next

If err.number<>0 then

redim Preserve Tab_Fichier_Erreur ( 1 to x)

Tab_Fichier_Erreur(x)= "Ton fichier"

x=x+1: Err.clear

On error goto 0

Le 24/08/2021 à 15:36

Pardon :

Bonjour Gabin37,

Par contre ta signature ne reflète pas trop la réalité

Le 24/08/2021 à 15:56

Par contre ta signature ne reflète pas trop la réalité

Mon fichier est vide... il ne contient que

Private Sub Workbook_Open()
Call ExcelSaveAsPDF(True)
End Sub

Je ne pense pas que cela soit pertinent

Je ne connaissais pas err.number ! c'est parfaitement ce qu'il me fallais

J'ai procédé comme cecla après chaque ouvertures:

            If Err.Number <> 0 Then
                Err.Clear
                msgerr = msgerr & Chr(13) & xStrFile1
            End If

Puis j'affiche le message à la fin en msgbox qui me donne la liste des fichiers qui n'ont pas pu être ouverts.

Merci Florian

Le 24/08/2021 à 16:19

Pour cloturer correctement je partage le code complet qui va m'être très utile personnellement:

Sub ExcelSaveAsPDF(entete As Boolean)
On Error Resume Next

Dim msgerr As String
msgerr = "Les fichiers suivants n'ont pas pu être convertis:" & Chr(13)

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
'Updateby Extendoffice
    Dim strPath As String
    Dim xStrFile1, xStrFile2 As String
    Dim xWbk As Workbook
    Dim xSFD, xRFD As FileDialog
    Dim xSPath As String
    Dim xRPath, xWBName As String
    Dim xBol As Boolean
    Set xSFD = Application.FileDialog(msoFileDialogFolderPicker)
    With xSFD
    .Title = "Choisir le dossier contenant les fichiers à convertir en PDF:"
    .InitialFileName = "C:\"
    End With
    If xSFD.Show <> -1 Then Exit Sub
    xSPath = xSFD.SelectedItems.Item(1)
    'Set xRFD = Application.FileDialog(msoFileDialogFolderPicker)
    'With xRFD
    '.Title = "Please select a destination folder to save the converted files:"
    '.InitialFileName = "C:\"
    'End With
    'If xRFD.Show <> -1 Then Exit Sub
    xRPath = xSPath & "\"
    strPath = xSPath & "\"
    xStrFile1 = Dir(strPath & "*.*")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    progress = 0
    UserForm2.Label1 = progress & " / " & tourmax
    UserForm2.Show
    Do While xStrFile1 <> ""
        xStrFile1 = Dir
        tourmax = tourmax + 1
    Loop
    xStrFile1 = Dir(strPath & "*.*")
    Do While xStrFile1 <> ""

        UserForm2.Label1 = progress & " / " & tourmax
        DoEvents
        xBol = False
        If Right(xStrFile1, 3) = "xls" Then
        Err.Clear
            Set xWbk = Workbooks.Open(Filename:=strPath & xStrFile1)
            If Err.Number <> 0 Then
                Err.Clear
                msgerr = msgerr & Chr(13) & xStrFile1
            End If
            n = 0
            If entete = True Then
                For Each feuil In xWbk.Worksheets
                If n > 0 Then feuil.Visible = False
                n = n + 1
                Next feuil
            End If
            xbwname = Replace(xStrFile1, ".xls", "_pdf")
            xBol = True
        ElseIf Right(xStrFile1, 4) = "xlsx" Then
        Err.Clear
            Set xWbk = Workbooks.Open(Filename:=strPath & xStrFile1)
            If Err.Number <> 0 Then
                Err.Clear
                msgerr = msgerr & Chr(13) & xStrFile1
            End If
            n = 0
            If entete = True Then
                For Each feuil In xWbk.Worksheets
                If n > 0 Then feuil.Visible = False
                n = n + 1
                Next feuil
            End If
            xbwname = Replace(xStrFile1, ".xlsx", "_pdf")
            xBol = True
        ElseIf Right(xStrFile1, 4) = "xlsm" Then
        Err.Clear
            Set xWbk = Workbooks.Open(Filename:=strPath & xStrFile1)
            If Err.Number <> 0 Then
                Err.Clear
                msgerr = msgerr & Chr(13) & xStrFile1
            End If
            n = 0
            If entete = True Then
                For Each feuil In xWbk.Worksheets
                If n > 0 Then feuil.Visible = False
                n = n + 1
                Next feuil
            End If
            xbwname = Replace(xStrFile1, ".xlsm", "_pdf")
            xBol = True
        End If
        If xBol Then
            xWbk.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xRPath & xbwname & ".pdf"
            xWbk.Close savechanges:=False
       End If
        xStrFile1 = Dir
        progress = progress + 1
    Loop
If Len(msgerr) > 53 Then MsgBox msgerr
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.AskToUpdateLinks = True
UserForm2.Hide
UserForm1.Show
End Sub

Avec en argument de la procédure vrai ou faux pour savoir si on convertis uniquement le premier onglet en PDF ou le classeur complet.

A+

Le 25/08/2021 à 10:33

Bonjour Gabin37,

A essayer mais je pense que ce code fais la même chose:

Sub ExcelSaveAsPDF(entete As Boolean)
    Dim xWbk               As Workbook
    Dim xSFD               As FileDialog
    Dim txt                As String
    Dim xStrFile1          As String
    Dim xSPath             As String
    Dim i                  As Integer
    Dim n                  As Integer
    Dim x                  As Integer
    Dim Tab_Fichier_Erreur()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.AskToUpdateLinks = False

    Set xSFD = Application.FileDialog(msoFileDialogFolderPicker)

    With xSFD
        .Title = "Choisir le dossier contenant les fichiers à convertir en PDF:"
        .InitialFileName = "C:\"
    End With

    If xSFD.Show <> -1 Then Exit Sub

    xSPath = xSFD.SelectedItems.Item(1)
    xStrFile1 = Dir(xSPath & Application.PathSeparator & "*.*")

    progress = 0
    UserForm2.Label1 = progress & " / " & tourmax
    UserForm2.Show

    Do While xStrFile1 <> ""
        xStrFile1 = Dir
        tourmax = tourmax + 1
    Loop

    xStrFile1 = Dir(xSPath & Application.PathSeparator & "*.*"): x = 0

    Do While xStrFile1 <> ""
        If TypeFichier(xStrFile1, xStrFile1) = True Then
            On Error Resume Next
            Set xWbk = Workbooks.Open(Filename:=xSPath & Application.PathSeparator & xStrFile1)
            On Error GoTo 0

            'Listing des fichiers en erreurs
            If Err.Number <> 0 Then
                x = x + 1
                ReDim Preserve Tab_Fichier_Erreur(1 To x)
                Tab_Fichier_Erreur(x) = "Ton fichier"
                Err.Clear
            End If

            n = 0
            If entete = True Then
                For Each feuil In xWbk.Worksheets
                    If n > 0 Then feuil.Visible = False
                    n = n + 1
                Next feuil
            End If

            xWbk.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xSPath & Application.PathSeparator & xStrFile1 & ".pdf"
            xWbk.Close savechanges:=False
        End If

        UserForm2.Label1 = progress & " / " & tourmax
        DoEvents
        xStrFile1 = Dir
        progress = progress + 1
    Loop

    If x > 0 Then
        For i = 1 To UBound(Tab_Fichier_Erreur, 1)
            If txt = "" Then
                txt = Tab_Fichier_Erreur(i) & Chr(13)
            Else
                txt = txt & Tab_Fichier_Erreur(i) & Chr(13)
            End If
        Next i

        MsgBox "Les fichiers suivants n'ont pas pu être convertis:" & Chr(13) & txt
    End If

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.AskToUpdateLinks = True
    UserForm2.Hide
    UserForm1.Show
End Sub
Function TypeFichier(ByRef fichier As String, NomFichier As String) As Boolean
   Dim t

   TypeFichier = False

   t = Split(NomFichier, ".")
   Select Case Left(t(UBound(t)), 3)
      Case "xls": TypeFichier = True
      fichier = t(0)

   End Select

End Function
Rechercher des sujets similaires à "vba gestion erreur lors ouverture fichiers"