Microsoft 365 Déclenchement macro en série suite à cellule fusionnées

[spike29]

Bonjour,

J'utilise un code permettant d'afficher la date du jour lorsque l'on double clic sur une cellule de la colonne Q.
Cette action déclenche une macro générant un mail.

La problématique est que les cellules de la colonne Q sont fusionnées par paquet de 4.
Avec ce code, après avoir double cliqué sur une cellule fusionnée la macro se déclenche à quatre reprise.

Comment faire en sorte qu'elle ne se déclenche qu'à une seule reprise ?
Le "For Each cell In R" ne doit pas être étranger à ma problématique mais je ne vois pas quoi mettre à la place.

Je précise que je n'ai pas la main sur la mise en forme du fichier et que je n'ai pas d'autre choix que de composer avec ces cellules fusionnées.
Merci d'avance pour votre aide.

Ci-dessous le code utilisé. Un fichier d'exemple est en PJ.

Bonne journée.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)


    If Intersect(Columns(17), Target) Is Nothing Then Exit Sub
    
        Target = Date 'Format(Now, "hh:mm")
        Cancel = True
    
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

c = ActiveCell

Set R = Intersect(Target, Columns(17))
If Not R Is Nothing Then
    
    For Each cell In R '<<< boucle


If IsDate(c) Then
mail


End If


 Next cell
 
End If


End Sub

 

[sousou]

Bonjour,
Je ne vois pas à quoi sert ta boucle

modifie comme ceci, et supprime worksheet change



Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)


If Intersect(Columns(17), Target) Is Nothing Then Exit Sub

Target.Value = Date 'Format(Now, "hh:mm")

c = Target.Rows(1)
If IsDate(c) Then
mail
End If
End Sub

 

[vgendron]

Hello

évidemment que ca lance 4 fois;. tu fais une boucle pour ca... d'ou la meme question que Sousou.. pourquoi??

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Intersect(Columns(17), Target) Is Nothing Then Exit Sub
    
    Target = Date 'Format(Now, "hh:mm")
    Cancel = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    c = ActiveCell
    Set R = Intersect(Target, Columns(17))
    If Not R Is Nothing Then
        'For Each cell In R '<<< boucle
            If IsDate(c) Then
                mail
            End If
        'Next cell
    End If
End Sub

et pour le code de ta macro mail.. faire un goto 1 alors qu'il suffit d'un exit sub..

Sub mail()
Dim c As Range
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim Signature As String
Dim CorpsDuMessage As String
Dim Texte As String
Dim Rep As Integer

    If MsgBox("Voulez-vous envoyer le mail ?", vbYesNo + vbQuestion, "Mail d'alerte") = vbNo Then Exit Sub
    
    ' Créer une instance d'Outlook
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    
    ' Afficher l'e-mail pour récupérer la signature par défaut
    With OutlookMail
        .Display
        Signature = .HtmlBody
    End With
    
    Set c = ActiveCell
    Num = c.Offset(0, -16).Value
    Dest = c.Offset(0, -9).Value
    
    Select Case Dest
        Case "JOE"
            LD1 = "Joe.Dalton@hotmail.fr"
        Case "JACK"
            LD1 = "Jack.Dalton@hotmail.fr"
        Case "WILLIAM"
            LD1 = "William.Dalton@hotmail.fr"
        Case "AVREL"
            LD1 = "Avrel.Dalton@hotmail.fr"
    End Select
    
    'If c.Offset(0, -9).Value Like "*HUP*" Then
    'LD1 = "audrey.hupenoire@sncf.fr"
    'End If
    
    ' Construire le corps du message
    Texte = Texte & "<p>Bonjour,</p>"
    Texte = Texte & "<p>Vous allez envoyer un mail ! <br> </p>"
    Texte = Texte & "<p>Bonne journée, <br> </p>"
    Texte = Texte & "Cordialement"
    
    ' Ajouter le corps du message et la signature
    With OutlookMail
        .To = LD1 & LD2 & LD3 & LD4 & LD5
        .Cc = ""
        .Subject = "#Mail pour la semaine n°" & " " & Num
        .HtmlBody = Texte & Signature
        .Display ' Utilisez .Send pour envoyer directement l'e-mail
        .Importance = 2 ' Niveau d'importance du mail
    End With
    
    ' Nettoyer les objets
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
End Sub

 

[spike29]

Bonjour,
Je ne vois pas à quoi sert ta boucle

modifie comme ceci, et supprime worksheet change



Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)


If Intersect(Columns(17), Target) Is Nothing Then Exit Sub

Target.Value = Date 'Format(Now, "hh:mm")

c = Target.Rows(1)
If IsDate(c) Then
mail
End If
End Sub

Bonjour Sousou,

merci du retour.

Concernant la boucle absolument aucune raison de sa présence. Il s'agit d'un copier collé d'un autre de mes codes et je ne me suis même pas posé la question de la boucle alors que oui c'est évident…
En enlevant simplement la boucle je n'ai plus ce problème de répétition du code.

La raison de la présence du module Worksheet_Change est qu'a la base je souhaitais laisser la possibilité à l'utilisateur de faire une saisie manuelle de la date dans la colonne Q. Mais je me suis aperçu que le résultat n'était pas bon car avec les "offset" en appuyant sur entré après avoir saisie sa date c'est la cellule du dessous qui est prise en compte et non la cellule ou on vient de saisir la date...

Merci en tout cas