Enlever le changement de page avec la fonction Worksheet_Calculate

Bonjour !

J'ai un problème avec la fonction Worksheet_Calculate () , concernant le changement de page.

Je m'explique, je rentre des valeurs dans ma première page et je fais un calcul dans ma deuxième page avec ces valeurs, je les utilise ensuite dans ma macro "Scansheet_Mainprocess" soit :

Private Sub Worksheet_Calculate()
    Dim Xrg As Range
    Set Xrg = Range("O2:P3000")
        If Not Intersect(Xrg, Range("O2:P3000")) Is Nothing Then
            ScanSheet_Mainprocess
        End If
End Sub

Donc des que je rentre des valeurs dans ma page 1 ma page 2 se met à jour et re-effectue les calculs avec les nouvelles valeurs.

Tout fonctionne parfaitement, je rencontre juste un problème sur l'affichage. Lorsque je change des valeurs dans ma page 1 Excel me redirige automatiquement vers ma page 2.

Serait-il possible d'empêcher le changement automatique de page ? Je remplis beaucoup de cellules dans ma première page, donc le changement de feuille active à chaque fois est très dérangeant.

En espérant avoir été assez clair pour que vous me compreniez !

Devery

Bonjour,

Montres la procédure "ScanSheet_Mainprocess()" !

Bonjour,

Le problème viens de la macro "ScanSheet_Mainprocess".

Tu peux nous la montrer ?

Sinon :

Private Sub Worksheet_Calculate()
    Dim Xrg As Range
    Set Xrg = Range("O2:P3000")
        If Not Intersect(Xrg, Range("O2:P3000")) Is Nothing Then
            ScanSheet_Mainprocess
            activeworkbook.sheets("Feuil1").activate
        End If
End Sub

Bonjour,

Le problème viens de la macro "ScanSheet_Mainprocess".

Tu peux nous la montrer ?

Sinon :

Private Sub Worksheet_Calculate()
    Dim Xrg As Range
    Set Xrg = Range("O2:P3000")
        If Not Intersect(Xrg, Range("O2:P3000")) Is Nothing Then
            ScanSheet_Mainprocess
            Activeworkbook.Sheets("Feuil1").Activate
        End If
End Sub

Bonjour,

Merci de vos réponses rapides, j'ai essayé d'ajouter la ligne supplémentaire mais je possède plusieurs feuilles que je modifie occasionnellement, le retour automatique sur cette page est donc un peu problèmatique.

activeworkbook.sheets("Feuil1").activate

La macro Scansheet_MainProcess envoi des mails automatiquement après qu'une date butoir est dépassée.

Voici son contenu :

Option Explicit
Const cColJoursRestants = 15
Const cColDateExpedMoinsRecue = 16
Const cColMailEnvoi = 17
Const cColMailEnvoi2 = 18
Const cNbJoursRelance2 = 3
Const cNbJoursRelance3 = 15
Const cColNumeroSubject = 14
Const cSubject = "Délai limite bientôt atteint"

Sub ScanSheet_Mainprocess()
    'Dim oCell As Integer
    Dim oCell As Excel.Range
    Worksheets("Commandes urgentes").Select

    If OL_OK Then

             For Each oCell In Worksheets("Commandes urgentes").UsedRange.Columns(cColJoursRestants).Cells
                  If oCell.Value <= cNbJoursRelance2 Then

                    If oCell.Offset(, cColMailEnvoi - cColJoursRestants).Value <> "Oui" Then
                      SendFollowUpMail Worksheets("Commandes urgentes"), oCell.Row

                       End If
                  End If
             Next

            For Each oCell In Worksheets("Commandes urgentes").UsedRange.Columns(cColDateExpedMoinsRecue).Cells

                  If oCell.Value <= cNbJoursRelance3 Then
                      If oCell.Offset(, cColMailEnvoi2 - cColDateExpedMoinsRecue).Value <> "Oui" Then
                       SendFollowUpMail2 Worksheets("Commandes urgentes"), oCell.Row

                       End If
                  End If
             Next

              '   MsgBox "Tous les mails d'avertissement on été envoyés!", vbExclamation, "FIN TRAITEMENT"
    Else
                 MsgBox "OUTLOOK n'est pas en exécution, veuillez lancer OUTLOOK et redémarrer le traitement." & vbCrLf & vbCrLf _
                 & "Pour redémarrer le traitement, relancez le fichier EXCEL ou utilisez le raccourci CTRL+D", vbCritical, "OUTLOOK NON ACTIF"

    End If

End Sub

Sub SendFollowUpMail(zSheet As Excel.Worksheet, zRow As Long)
    Const cColMailList = 19
    Const cColMailBody = 20
    Const cSep = vbLf
    Const cMailItem = 0
    Dim oOL As Object
    Dim oMail As Object
    Dim oCell As Excel.Range

    Dim sRecipients As String
    Dim aRecipients() As String
    Dim sBody As String
    Dim i As Integer

    'on récupère sur la ligne sélectionnée les données pour l'envoi
    Set oCell = zSheet.Cells(zRow, cColMailList)
    sRecipients = oCell.Value
    Set oCell = zSheet.Cells(zRow, cColMailBody)
    sBody = oCell.Value

    'On s'assure que les données soient disponibles
    If Len(sRecipients) > 0 And Len(sBody) > 0 Then
        On Error GoTo ErrorHandling
       ' Set oOL = GetObject(, "Outlook.Application")
        Set oOL = CreateObject("Outlook.Application")
        Set oMail = oOL.CreateItem(cMailItem)
        With oMail
            'On ajoute autant de destinataires que nécessaire
            aRecipients() = Split(Replace(sRecipients, cSep, ";"), ";")
            For i = 0 To UBound(aRecipients)
                .Recipients.Add aRecipients(i)
            Next
            .Subject = cSubject
            .Body = sBody
            .Send
        End With
        'On indique que le mail a été envoyé
        Set oCell = zSheet.Cells(zRow, cColMailEnvoi)
        oCell.Value = "Oui"
        oCell.Font.Bold = True
    End If
    GoTo Cleaning
ErrorHandling:
    Dim sMess As String
    sMess = "Erreur " & Err.Number & vbCrLf & vbCrLf _
        & Err.Description & vbCrLf & vbCrLf _
        & "Veuillez vérifier les adresses mails!"

    MsgBox sMess, vbCritical, "ERREUR MAIL"
    If Not oMail Is Nothing Then
        oMail.Display
    End If
Cleaning:
    'On fait le ménage
    Set oCell = Nothing
    Set oOL = Nothing
    Set oMail = Nothing

End Sub

Sub SendFollowUpMail2(zSheet As Excel.Worksheet, zRow As Long)
    Const cColMailList2 = 19
    Const cColMailBody2 = 21
    Const cSep = vbLf
    Const cMailItem = 0
    Dim oOL As Object
    Dim oMail As Object
    Dim oCell As Excel.Range

    Dim sRecipients As String
    Dim aRecipients() As String
    Dim sBody As String
    Dim i As Integer

    'on récupère sur la ligne sélectionnée les données pour l'envoi
    Set oCell = zSheet.Cells(zRow, cColMailList2)
    sRecipients = oCell.Value
    Set oCell = zSheet.Cells(zRow, cColMailBody2)
    sBody = oCell.Value

    'On s'assure que les données soient disponibles
    If Len(sRecipients) > 0 And Len(sBody) > 0 Then
        On Error GoTo ErrorHandling
       ' Set oOL = GetObject(, "Outlook.Application")
       Set oOL = CreateObject("Outlook.Application")
        Set oMail = oOL.CreateItem(cMailItem)
        With oMail
            'On ajoute autant de destinataires que nécessaire
            aRecipients() = Split(Replace(sRecipients, cSep, ";"), ";")
            For i = 0 To UBound(aRecipients)
                .Recipients.Add aRecipients(i)
            Next
            .Subject = cSubject
            .Body = sBody
            .Send
        End With
        'On indique que le mail a été envoyé
        Set oCell = zSheet.Cells(zRow, cColMailEnvoi2)
        oCell.Value = "Oui"
        oCell.Font.Bold = True
    End If
    GoTo Cleaning
ErrorHandling:
    Dim sMess As String
    sMess = "Erreur " & Err.Number & vbCrLf & vbCrLf _
        & Err.Description & vbCrLf & vbCrLf _
        & "Veuillez vérifier les adresses mails!"

    MsgBox sMess, vbCritical, "ERREUR MAIL"
    If Not oMail Is Nothing Then
        oMail.Display
    End If
Cleaning:
    'On fait le ménage
    Set oCell = Nothing
    Set oOL = Nothing
    Set oMail = Nothing

End Sub

Function OL_OK() As Boolean

    Dim oOL As Object
    On Error GoTo OL_NOK
    Set oOL = GetObject(, "Outlook.application")
    OL_OK = True
    Set oOL = Nothing
    Exit Function
OL_NOK:
    OL_OK = False
    Set oOL = Nothing
End Function

Supprime déjà cette ligne de code :

Worksheets("Commandes urgentes").Select

Effectivement j'ai juste eu à supprimer cette ligne pour supprimer le problème

Un grand merci à vous deux pour votre aide

Bonne journée !

Devery