Modification d'une cellule dans une feuille avec Worksheet_change

Question

Bonjour Community :)

J'ai un petit problème, je cherche à écrire une code que si une cellule dans une feuille prend une valeur donnée, on demande la confirmation de l'utilisateur, si il choisit oui, on procède à des manipulation, sinon on ne change pas la valeur initiale de la cellule et on fait rien. Mon code actuel fonctionne bien mais à condition qu'on valide la modification. Sinon mon fichier Excel se ferme. Qqn a une idée pour moi, je n'arrive pas à trouver où est le problème

Option Explicit
Dim val As Variant
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    Dim Destinataire As String, xOutApp As Object, OutMail As Object, xMailItem As String
    Dim xMailBody As String, SigString As String, Signature As String, DernLigne As Long, nomfeuille As String, ThisRow As Long
Dim i As Integer, Cpt As Integer, CptSh As Integer, dercol As Long
Dim ok As Boolean
Dim a
On Error Resume Next
If ok = True Then Exit Sub
If Target.Column = 10 And Target.Value = "Gagnée" Then
    a = MsgBox("Attention, vous vous apprêtez à modifier cette valeur. Continuer ?", vbYesNo + vbQuestion, "Modification de l'état de vente")
        If a = vbYes Then
    Cpt = 0
    CptSh = Sheets.Count
    For i = 1 To CptSh
        If Sheets(i).Name <> "Clients Gagnés 2021" Then Cpt = Cpt + 1 Else Exit For
    Next i
    If Cpt = CptSh Then
         Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Clients Gagnés 2021"
         Sheets("Affaires 2021").Rows(1).EntireRow.Copy
         Sheets("Clients Gagnés 2021").Select
Sheets("Clients Gagnés 2021").Cells(1, 1).EntireRow.Select
ActiveSheet.Paste
   Application.CutCopyMode = False

   dercol = Sheets("Clients Gagnés 2021").Range("IV1").End(xlToLeft).Column + 1
   Sheets("Clients Gagnés 2021").Cells(1, dercol).Value = "N°Installation"
    Sheets("Clients Gagnés 2021").Range("A1").Select
     ActiveWindow.SmallScroll ToRight:=23
     Selection.Copy
     Sheets("Clients Gagnés 2021").Cells(1, dercol).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    End If
    DernLigne = Sheets("Clients Gagnés 2021").Range("a65536").End(xlUp).Row + 1
    ThisRow = Target.Row
    Sheets("Affaires 2021").Rows(ThisRow).EntireRow.Copy
         Sheets("Clients Gagnés 2021").Select
Sheets("Clients Gagnés 2021").Cells(DernLigne, 1).EntireRow.Select
ActiveSheet.Paste
   Application.CutCopyMode = False
        Set xOutApp = CreateObject("Outlook.Application")
        Set OutMail = xOutApp.CreateItem(0)
        Destinataire = "xx@xx.com"
        xMailItem = "Une nouvelle offre a été rapportée"
        xMailBody = "xx"
        SigString = Environ("appdata") & _
                "\Microsoft\Signatures\xx.htm"
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
    On Error Resume Next
        With OutMail
            .To = Destinataire
            .Subject = xMailItem
            .HTMLBody = xMailBody & "<br>" & Signature
            .Attachments.Add (ThisWorkbook.FullName)
            .Display
        End With
        Sheets("Clients Gagnés 2021").Select
        nomfeuille = ActiveSheet.Name
        MsgBox ("Un e-mail a été envoyé à " & Destinataire & " et le nouveau client gagné a été ajouté à la feuille " & nomfeuille)
        End If
        Else: Target = val
        End If
        ok = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Sheets("Clients Gagnés 2021").Range("A" & DernLigne).RemoveDuplicates Columns:=1, Header:=xlNo
End Sub
Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
val = Target.Value
End Sub

eriiic · Accepted Answer

Oui sans aucun doute. Mais les mails ce n'est pas ma tasse de thé. Démarre un nouveau topic avec un titre en rapport. Sinon pour concaténer : txt ="Bonjour " & Cells(lig,col).Value (je ne sais pas trop quelle cellule tu veux) eric...

eriiic · Answer

Commence par enlever cet horrible On Error Resume Next qui met la poussière sous le tapis et t'empêche de voir les erreurs à corriger. On ne met cette instruction que pour une erreur attendue et normale. On remet On Error Goto 0 après l'instruction en cause pour reprendre la gestion d'erreur Pourquoi ne pas utiliser la déclaration faite par VBA Private Sub Worksheet_Change(ByVal Target As Range) et mettre Private Sub Worksheet_Change(ByVal Target As Excel.Range) ? If ok = True Then Exit Sub comment veux-tu qu'il soit True ?? Tu viens juste de le déclarer, il est obligatoirement False Else: Target = val Pour la lisibilité tu aurais dû l'écrire sur 2 lignes. à quoi est égal val ? Pas vu son initialisation.. . EDIT : vu en bas Pour annuler une saisie on peut faire Application.Undo ok = False idem, encore une ligne inutile à supprimer actuellement eric...