Incrémenter un champs Excel dans un code VBA

[sylvain78b]

Bonjour,

Dans le cadre d'un projet dans mon entreprise, je souhaiterais envoyer un email automatiquement (par outlook) en fonction de la modification d'une cellule. L'idée serait que le mail soit envoyé directement aux commerciaux responsables du secteur, pour une validation.

Mais j'ai un problème car les destinataires ne sont pas obligatoirement les mêmes pour chaque validation.

Colonne B : Nous avons des cellules de validation qui permet aux vendeurs de valider la ligne avec une croix
Colonne F et G : Les personnes qui doivent valider

Avec le code actuellement en place, lorsque nous avons une modification en colonne B un mail est automatiquement généré. J'aimerais que le nom du destinataire correspondant à la ligne soit inséré automatiquement.

Par exemple quand la case de validation (B3) est cochée, cela insère automatiquement les valeurs de F3 et G3
B4 = F4 = G4 etc etc...

Voici mon code :

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xRgSel As Range
    Dim xOutApp As Object
    Dim xMailItem As Object
    Dim xMailBody As String
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set xRg = Range("B2:B80")
    Set xRgSel = Intersect(Target, xRg)
    ActiveWorkbook.Save
    If Not xRgSel Is Nothing Then
        Set xOutApp = CreateObject("Outlook.Application")
        Set xMailItem = xOutApp.CreateItem(0)
        xMailBody = "Bonjour à tous," & vbNewLine & vbNewLine & _
        "Un nouveau produit à été ajouté à le classeur, en cellule " & xRgSel.Address(False, False) & _
            "' le " & _
            Format$(Now, "mm/dd/yyyy") & " à " & Format$(Now, "hh:mm") & _
            " par " & Environ$("username") & "." & vbNewLine & vbNewLine & _
            "Le classeur est consultable à cette adresse : " & ThisWorkbook.FullName & vbNewLine & vbNewLine & _
            "Merci par avance pour votre validation express," & vbNewLine & vbNewLine & _
            "L'équipe"
        With xMailItem
            .To = 'QUOI METTRE ICI ? :'(
            .Subject = "EDC - Validation "
            .Body = xMailBody
            .Display
        End With
        Set xRgSel = Nothing
        Set xOutApp = Nothing
        Set xMailItem = Nothing
    End If
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Merci

 

[Compte Supprimé 979]

Bonjour Sylvain78b

Juste un petit changement à faire au niveau de ton code

.To = Cells(Target.Row, 6).Value

A+

 

[sylvain78b]

Alléluia !!!! Merci beaucoup Bruno