Sauvegarde automatique dérangeante

Bonjour,

Je possède un tableau Excel avec des codes VBA, mais j'ai un soucis de sauvegardes intempestives à chaque nouvelle valeur dans un champs. Est-ce possible de supprimer cette fonction ?

Je ne trouve absolument pas la méthode :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRgSel As Range, cel As Range, rng As Range
Dim xOutApp As Object
Dim xMailItem As Object
Dim xMailBody As String
    Application.ScreenUpdating = False
    Set xRg = Range("AQ4:AQ273")
    Set xRgSel = Intersect(Target, xRg)
    If Not xRgSel Is Nothing Then
        Me.Unprotect 1234
        For Each cel In xRgSel.Cells
            If UCase(cel.Value) = "X" Then
                Set rng = Intersect(cel.EntireRow, Me.Columns("H:V"))
                rng.Value = rng.Value
                cel.EntireRow.Cells(1, "B").Value = "X"
            End If
        Next cel
        Me.Protect 1234
    End If
    Set xRgSel = Range("B4:B273")
    Set xRgSel = Intersect(Target, xRgSel)
    ActiveWorkbook.Save
    If Not xRgSel Is Nothing Then
        On Error Resume Next
        Application.DisplayAlerts = False
        Set xOutApp = CreateObject("Outlook.Application")
        Set xMailItem = xOutApp.CreateItem(0)
        xMailBody = "Bonjour à tous," & vbNewLine & vbNewLine & _
        "Merci de valider les informations présentes dans les parties :" & vbNewLine & vbNewLine & _
        "Un nouvel " & Cells(Target.Row, 25) & " à été ajouté  " & Cells(Target.Row, 8) & " (" & Cells(Target.Row, 9) & ")" & " dans  " & xRgSel.Address(False, False) & _
            "' le " & _
            Format$(Now, "mm/dd/yyyy") & " à " & Format$(Now, "hh:mm") & _
            " par " & Environ$("username") & "." & vbNewLine & vbNewLine & _
            "Voici le numéro  du compte : " & Cells(Target.Row, 7) & vbNewLine & vbNewLine & _
             "L'équipe "
        With xMailItem
            .To = Cells(Target.Row, 14)
            .Cc = "XXXXX"
            .Subject = "Validation de votre part - " & Cells(Target.Row, 8) & " - " & Cells(Target.Row, 25)
            .Body = xMailBody
            .Display
        End With
        Set xRgSel = Nothing
        Set xOutApp = Nothing
        Set xMailItem = Nothing
        Application.DisplayAlerts = True
        On Error GoTo 0
    End If
    Set xRgSel = Range("AR4:AR273")
    Set xRgSel = Intersect(Target, xRgSel)
    ActiveWorkbook.Save
    If Not xRgSel Is Nothing Then
        On Error Resume Next
        Application.DisplayAlerts = False
        Set xOutApp = CreateObject("Outlook.Application")
        Set xMailItem = xOutApp.CreateItem(0)
                xMailBody = "Bonjour à tous," & vbNewLine & vbNewLine & _
        "Merci de valider les informations présentes dans les parties :" & vbNewLine & vbNewLine & _
        "Un nouvel " & Cells(Target.Row, 25) & " à été ajouté  " & Cells(Target.Row, 8) & " (" & Cells(Target.Row, 9) & ")" & " dans  " & xRgSel.Address(False, False) & _
            "' le " & _
            Format$(Now, "mm/dd/yyyy") & " à " & Format$(Now, "hh:mm") & _
            " par " & Environ$("username") & "." & vbNewLine & vbNewLine & _
            "Voici le numéro  du compte : " & Cells(Target.Row, 7) & vbNewLine & vbNewLine & _
             "L'équipe "
        With xMailItem
            .To = Cells(Target.Row, 15)
            .Cc = "XXXXX"
            .Subject = "Validation de votre part - " & Cells(Target.Row, 8) & " - " & Cells(Target.Row, 25)
            .Body = xMailBody
            .Display
        End With
        Set xRgSel = Nothing
        Set xOutApp = Nothing
        Set xMailItem = Nothing
        Application.DisplayAlerts = True
        On Error GoTo 0
    End If
    Application.ScreenUpdating = True
End Sub

Merci

Bonjour,

La sauvegarde correspondant aux instructions :

ActiveWorkbook.Save

Bonjour,

supprime les deux lignes

ActiveWorkbook.Save

Merci beaucoup

sylvain78 a écrit :

Merci beaucoup

Pas de quoi !