1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71
| Private Sub Worksheet_Change(ByVal Target As Range)
If (Target.Column = 9) And (ActiveSheet.Cells(Target.Row, Target.Column).Value <> "") Then
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
laligne = Target.Row
info = MsgBox("Transférer cette ligne sur la feuille 'Envoyés' ?", vbYesNo + vbInformation, "Tableau de suivi des SFR")
If (info = vbYes) Then
Rows(laligne & ":" & laligne).Copy
Sheets("Envoyés").Select
ligne = 2
While ThisWorkbook.Sheets("Envoyés").Range("A" & ligne).Value <> ""
ligne = ligne + 1
Wend
ThisWorkbook.Sheets("Envoyés").Rows(ligne & ":" & ligne).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("A envoyer").Select
Rows(laligne & ":" & laligne).Delete Shift:=xlUp
Application.CutCopyMode = False
End If
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
ElseIf (Target.Column = 8) And (ActiveSheet.Cells(Target.Row, Target.Column).Value <> "") Then
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
laligne = Target.Row
info = MsgBox("Prévenir ADV ?", vbYesNo + vbInformation, "Tableau de suivi des SFR")
If (info = vbYes) Then
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "<font size=""3"" face=""Calibri"">" & _
"Bonjour,<br><br>" & _
"La documentation<B> " & Cells(ActiveCell.Row, 1).Value & " </B>est disponible." & _
"<br><br>Cordialement</font>"
With OutMail
.To = "***@***.com"
.CC = ""
.BCC = ""
.Subject = "SFR Disponible"
.HTMLBody = strbody
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End If
End If
End Sub |
Partager