Désactiver une Private Sub

Le 01/01/2016 à 11:04

Bonjour,

Dans une feuille Excel j'ai 2 private sub qui s'enchaînent.

Comment coder pour que la message box d'erreur qui peut s'afficher en cas de soucis via la private sub 1 fasse en sorte que la private sub 2 ne s'exécute pas ?

D'avance merci et bonne année !

Le 01/01/2016 à 12:02

Bonjour,

En cas de message d'erreurs, il faut ajouter une ligne "Exit Sub". Si on voit ton code, le conseil sera plus affiné.

Le 01/01/2016 à 12:29

Re-bonjour,

Je joins le code en l'ayant un peu raccourcis...

J'ai mis le commentaire après l'affichage de la MsgBox.

J'ai essayé quelques "bricoles" mais il doit me manquer quelque chose...

Private Sub CreerRep(peType As E_Type, piLig As Integer)

    Dim oShSource As Worksheet
    Dim sNumero As String
    Dim sNomNorme As String
    Dim sCheminRep As String
    Dim sNomModele As String
    Dim sCheminModele As String

    If goFSO Is Nothing Then
        Set goFSO = New FileSystemObject
    End If

    Set oShSource = Worksheets("Feuil1")

    sNumero = oShSource.Range("A" & piLig).Value

    sNomNorme = sNumero & "-" & (oShSource.Range("H" & piLig).Value) & " - "
    If peType = E_exemple1 Then
        sNomNorme = sNomNorme & "ex1"
        sNomModele = "Ex1.pdf"
        sCheminModele = "C:\Users\EXEMPLE 1\"
        sCheminRep = "C:\Users\EXEMPLE 1 PDF\"
    ElseIf peType = E_exemple2 Then
        sNomNorme = sNomNorme & "ex2"
        sNomModele = "ex2.pdf"
        sCheminModele = "C:\Users\EXEMPLE 2\"
        sCheminRep = "C:\Users\EXEMPLE 2 PDF\"

    Else
        MsgBox "Type inconnu : " & vbCrLf & peType, vbExclamation
        sNomNorme = sNomNorme & "Inconnu"
    End If
    sNomNorme = sNomNorme & " - " & oShSource.Range("C" & piLig).Value

    sNomNorme = sNomNorme & " - " & oShSource.Range("I" & piLig).Value

    Set oShSource = Nothing

    If Right(sCheminRep, 1) <> "\" Then
        sCheminRep = sCheminRep & "\"
    End If
    sCheminRep = sCheminRep & sNomNorme & "\"

    If goFSO.FolderExists(sCheminRep) Then

        MsgBox "Le répertoire existe déjà !" & vbCrLf & sCheminRep, vbExclamation
     '************************
     'Si cette message box se déclenche il faut que la private sub AlimCible ci-après ne se déclenche pas
     '************************
    Exit Sub

    Else
        goFSO.CreateFolder sCheminRep
    End If

    If Right(sCheminModele, 1) <> "\" Then
        sCheminModele = sCheminModele & "\"
    End If
    sCheminModele = sCheminModele & sNomModele

    If Dir(sCheminModele) = "" Then
        MsgBox "Modèle non trouvé : " & vbCrLf & sCheminModele, vbExclamation
    Else
        goFSO.CopyFile sCheminModele, sCheminRep & sNomNorme & ".pdf"

    End If
End Sub

Private Sub AlimCible(poSh As Worksheet, piLig As Integer)

    Dim oShSource As Worksheet
    Dim iCol As Integer

    Set oShSource = Worksheets("Feuil1")

    poSh.Rows("8:8").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    poSh.Range("A9:N9").Copy
    poSh.Range("A8").PasteSpecial xlPasteAll
    Application.CutCopyMode = False

    Set oShSource = Nothing

    Range("B8").Select

End Sub

Merci.

Le 01/01/2016 à 13:10

Re,

Je ne vois aucun enchainement ou appel entre deux procédures. Je ne peux faire aucun test faute de fichier qui va avec. Essaye de déboguer ligne par ligne de ton coté.

Le 01/01/2016 à 15:15

J'avais oublié cette partie du code. En fait l'incrémentation du registre est déclenchée par ce code et je n'arrive pas à faire en sorte que si l'entrée de répertoire existe déjà,alors l'AlimCible ne se fasse pas...

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

    Dim oShCible As Worksheet
    Dim bOK As Boolean
    Dim eType As E_Typ
    Dim iCol As Integer
    Dim sMsg As String

    bOK = False
    If Target.Column >= 29 And Target.Column <= 42 Then

        ElseIf Target.Value = "OUI" Then
            If Target.Column = 30 Then
                Set oShCible = Worksheets("EXEMPLE 1")
                eType = E_Ex1
                bOK = True

            ElseIf Target.Column = 31 Then
                Set oShCible = Worksheets("EXEMPLE 2")
                eType = E_Ex2
                bOK = True

        Else
                MsgBox "Pas normal !"
            End If

            AlimCible oShCible, Target.Row

            CreerRep eType, Target.Row

            Set oShCible = Nothing
        End If

     End If  

End Sub

Si la solution existe je prends de suite !

Merci d'avance.

Le 01/01/2016 à 15:45

Re,

Dans cette procédure suivante :

Private Sub CreerRep(peType As E_Type, piLig As Integer)

Remplace

Exit Sub

par

End

et teste.

Le 01/01/2016 à 16:07

De sortie j'essaye ce soir avec impatience...

Le 01/01/2016 à 20:42

Malheureusement j'ai essayé plusieurs solution mais rien n'y fait.

Je vais creuser encore...

Bonne soirée.

Le 01/01/2016 à 23:03

Bonsoir,

vous pouvez créer une variable boolean Public Si_Répertoire

Public Si_Répertoire as Boolean

Ensuite dans votre code inverser le lancement des différentes private sub :

Public Si_Répertoire As Boolean

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

    Dim oShCible As Worksheet
    Dim bOK As Boolean
    Dim eType As E_Typ
    Dim iCol As Integer
    Dim sMsg As String

    bOK = False
    If Target.Column >= 29 And Target.Column <= 42 Then

        ElseIf Target.Value = "OUI" Then
            If Target.Column = 30 Then
                Set oShCible = Worksheets("EXEMPLE 1")
                eType = E_Ex1
                bOK = True

            ElseIf Target.Column = 31 Then
                Set oShCible = Worksheets("EXEMPLE 2")
                eType = E_Ex2
                bOK = True

        Else
                MsgBox "Pas normal !"
            End If
Si_Répertoire = False

             CreerRep eType, Target.Row

            If Si_Répertoire = False Then
                AlimCible oShCible, Target.Row
            End If

            Set oShCible = Nothing
        End If

     End If

End Sub

ensuite dans la Sub où se trouve le test :

Private Sub CreerRep(peType As E_Type, piLig As Integer)

    Dim oShSource As Worksheet
    Dim sNumero As String
    Dim sNomNorme As String
    Dim sCheminRep As String
    Dim sNomModele As String
    Dim sCheminModele As String

    If goFSO Is Nothing Then
        Set goFSO = New FileSystemObject
    End If

    Set oShSource = Worksheets("Feuil1")

    sNumero = oShSource.Range("A" & piLig).Value

    sNomNorme = sNumero & "-" & (oShSource.Range("H" & piLig).Value) & " - "
    If peType = E_exemple1 Then
        sNomNorme = sNomNorme & "ex1"
        sNomModele = "Ex1.pdf"
        sCheminModele = "C:\Users\EXEMPLE 1\"
        sCheminRep = "C:\Users\EXEMPLE 1 PDF\"
    ElseIf peType = E_exemple2 Then
        sNomNorme = sNomNorme & "ex2"
        sNomModele = "ex2.pdf"
        sCheminModele = "C:\Users\EXEMPLE 2\"
        sCheminRep = "C:\Users\EXEMPLE 2 PDF\"

    Else
        MsgBox "Type inconnu : " & vbCrLf & peType, vbExclamation
        sNomNorme = sNomNorme & "Inconnu"
    End If
    sNomNorme = sNomNorme & " - " & oShSource.Range("C" & piLig).Value

    sNomNorme = sNomNorme & " - " & oShSource.Range("I" & piLig).Value

    Set oShSource = Nothing

    If Right(sCheminRep, 1) <> "\" Then
        sCheminRep = sCheminRep & "\"
    End If
    sCheminRep = sCheminRep & sNomNorme & "\"

    If goFSO.FolderExists(sCheminRep) Then

        MsgBox "Le répertoire existe déjà !" & vbCrLf & sCheminRep, vbExclamation
'************************
        'Si cette message box se déclenche il faut que la private sub AlimCible ci-après ne se déclenche pas
        '************************

        'ici on met Si_Répertoire à vrai car le dossier existe
        Si_Répertoire = True

        Exit Sub

    Else
        goFSO.CreateFolder sCheminRep
    End If

    If Right(sCheminModele, 1) <> "\" Then
        sCheminModele = sCheminModele & "\"
    End If
    sCheminModele = sCheminModele & sNomModele

    If Dir(sCheminModele) = "" Then
        MsgBox "Modèle non trouvé : " & vbCrLf & sCheminModele, vbExclamation
    Else
        goFSO.CopyFile sCheminModele, sCheminRep & sNomNorme & ".pdf"

    End If
End Sub

Private Sub AlimCible(poSh As Worksheet, piLig As Integer)

    Dim oShSource As Worksheet
    Dim iCol As Integer

    Set oShSource = Worksheets("Feuil1")

    poSh.Rows("8:8").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    poSh.Range("A9:N9").Copy
    poSh.Range("A8").PasteSpecial xlPasteAll
    Application.CutCopyMode = False

    Set oShSource = Nothing

    Range("B8").Select

End Sub

du coup on "chope" que le dossier existe, on passe la variable Si_Répertoire à vrai, du coup on ne lance pas la deuxième sub, du coup vous êtes content ?

@ bientôt

LouReeD

Le 02/01/2016 à 09:34

Bonjour,

C'est absolument parfait. J'ai trituré mon tableur dans tous les sens et avec ce code tout est comme il faut et il n'y a pas de bug.

Merci encore.

Bonne journée.

Le 02/01/2016 à 09:52

Bonjour,

ravis que cela vous convienne !

Merci de votre merci et bonne année @ vous !

@ bientôt

LouReeD

Rechercher des sujets similaires à "desactiver private sub"