Microsoft 365 Problème d'extraction de données pour envoi par mail

[lebel]

Bonjour, j'ai une routine qui doit me permettre d'envoyer certaines données par mail , une grande partie de mon code s'exécute parfaitement mais malgré une condition : si dans colonne F je rencontre à nouveau une valeur = "x", j'arrête l'extraction des données :

je vous joins le code et une image du mail généré
MERCI de votre AIDE.

 

[sylvanu]

Bonsoir Lebel,
Sans fichier test, c'est un peu au pif.
Après test il s'avère que le IF soit sensible à la casse. "X" est différent de "x".
Essayez pour voir :

If UCase(Cells(currentRow, "F").Value) = "X" Then

Sinon essayez de fournir un petit fichier test.
Par ex avec un x minuscule en F24 :
Code original :

Code modifié :

 

[lebel]

Merci pour vos suggestions.
Ce n'était pas le "X" mais "w" qui me posait un problème.
Tout est Ok pour la construction du mail.
Encore MERCI

 

[sylvanu]

Bonsoir,
Au vu de votre macro, je ne comprends pas comment le "w" pouvait poser problème. 🙁
La prochaine fois poster un fichier test ( sous format XL ) ce sera plus simple pour comprendre. 🙂

 

[TooFatBoy]

Bonjour,

Tout comme le camarade sylvanu je ne vois pas comment le "W" peut poser problème vu que le test se fait sur le "X".
Donc je n'ai pas compris si le problème est résolu ou non, et du coup je fais une proposition de modification de la macro postée en fichier TXT.

Sub CreerEmail()
'
Dim OutlookApp As Object, OutlookMail As Object
Dim ws As Worksheet
Dim cell As Range
Dim emailAddress As String, bodyText As String
Dim currentRow As Long

    ' Définir la feuille
    Set ws = ThisWorkbook.Sheets("Inscript Rando & Scan accueil")

    ' Vérifier si une cellule dans la colonne Y est sélectionnée
    If Not Intersect(Selection, ws.Range("Y4:Y1100")) Is Nothing Then

        Set cell = Selection

        ' Récupérer l'adresse email
        emailAddress = ws.Cells(cell.Row, "U").Value

        ' Commencer à rédiger le corps de l'email
        bodyText = "Veuillez trouver ci-joint la confirmation de votre inscription." & vbCrLf & vbCrLf

        currentRow = cell.Row

        ' Collecter les données jusqu'à ce qu'il trouve "X" dans la colonne F ou jusqu'à la fin de la plage de données
        Do
            bodyText = bodyText & "Nom: " & ws.Cells(currentRow, "G").Value & vbCrLf
            bodyText = bodyText & "Prénom: " & ws.Cells(currentRow, "H").Value & vbCrLf
            bodyText = bodyText & "Code: " & ws.Cells(currentRow, "V").Value & vbCrLf
            bodyText = bodyText & "Choix: " & ws.Cells(currentRow, "F").Value & vbCrLf & vbCrLf
            currentRow = currentRow + 1
        Loop While currentRow <= 1100 And UCase(ws.Cells(currentRow, "F").Value) <> "X"

        ' Créer un email dans Outlook après avoir collecté toutes les données
        Set OutlookApp = CreateObject("Outlook.Application")
        Set OutlookMail = OutlookApp.CreateItem(0)

        With OutlookMail
            .To = emailAddress
            .Subject = "Confirmation d'inscription"
            .Body = bodyText
            .Display ' Afficher l'email (utiliser .Send pour envoyer directement)
        End With

        ' Nettoyer
        Set OutlookMail = Nothing
        Set OutlookApp = Nothing

    Else

        MsgBox "Veuillez sélectionner une cellule dans la colonne Y4:Y1100.", vbExclamation

    End If

End Sub