sALU a tous
je souhaiterais ameliorer le code vba ci dessous afin d ' eviter le message d ' alerte 'autorisation d ' excel avant d effectuer l ' envoie automatique d ' email via outlook lors de l execution de ma macro.
Aussi serait t ' il possible de rajouter dans le corp de mon courriel le message " Salu." .
je vous remercie d ' avance pour votre aide
LGVBA
Dim Destinataire As String, Sujet As String
'Dim AccuseReception As Boolean
Destinataire = Adresse_courriel
Sujet = "Décompte personnel"
ThisWorkbook.Sheets("Base courriel").Copy
ActiveWorkbook.SendMail Destinataire, Sujet
ActiveWorkbook.Close False
Mon code vba en entier
Sub aaa()
Dim Début As Integer, Fin As Integer, Grand_total As Currency, ID_traité As String, Nom_traité As String
Dim feuillenom As String, i As Integer, Adresse_courriel As String
Application.ScreenUpdating = False
feuillenom = Date '& " - " & Hour(Time) & "h " & Minute(Time) & "m"
Sheets("Base").Copy After:=Sheets(1)
'Sheets("Base2").Name = feuillenom
Columns("F:F").NumberFormat = "#,##0.00"
ActiveSheet.Shapes("Button 1").Delete
Range("A2").Activate
Retour:
ID_traité = ActiveCell
Nom_traité = ActiveCell.Offset(0, 1)
With Sheets("Adresses électroniques")
For i = 2 To .Range("A65000").End(xlUp).Row
If .Cells(i, 1) = ID_traité And .Cells(i, 2) = Nom_traité Then Adresse_courriel = .Cells(i, 3)
Next i
End With
Début = ActiveCell.Row
Do Until ActiveCell <> ID_traité Or ActiveCell.Offset(0, 1) <> Nom_traité
ActiveCell.Offset(1, 0).Activate
Loop
Fin = ActiveCell.Row - 1
Rows(Fin + 1 & ":" & Fin + 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(ActiveCell.Row, 5) = "Total"
Cells(ActiveCell.Row, 6) = WorksheetFunction.Sum(Range(Cells(Début, 6), Cells(Fin, 6)))
Grand_total = Grand_total + Cells(ActiveCell.Row, 6)
Range(Cells(ActiveCell.Row, 5), Cells(ActiveCell.Row, 6)).Font.Bold = True
With Range(Cells(ActiveCell.Row, 5), Cells(ActiveCell.Row, 6)).Interior
.Color = 5296274
End With
With Range(Cells(ActiveCell.Row, 5), Cells(ActiveCell.Row, 6))
.BorderAround Weight:=xlMedium
End With
With Range(Cells(ActiveCell.Row + 1, 1), Cells(ActiveCell.Row + 1, 6)).Interior
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.349986266670736
End With
Range(Cells(Début, 1), Cells(Fin, 6)).Borders.Weight = xlThin
'Report individuel sur feuille "Base courriel"
With Sheets("Base courriel")
.Range("A2:F65000").Delete
Range(Cells(Début, 1), Cells(Fin + 1, 6)).Copy Destination:=.Range("A2")
End With
Dim Destinataire As String, Sujet As String
Dim AccuseReception As Boolean
Destinataire = Adresse_courriel
Sujet = "Détail Prélevement Bancaire"
ThisWorkbook.Sheets("Base courriel").Copy
ActiveWorkbook.SendMail Destinataire, Sujet
ActiveWorkbook.Close False
ActiveCell.Offset(2, 0).Activate
If ActiveCell = "" Then
Cells(Fin + 3, 5) = "Grand Total"
Cells(Fin + 3, 6) = Grand_total
Range(Cells(Fin + 3, 5), Cells(Fin + 3, 6)).Font.Bold = True
With Range(Cells(Fin + 3, 5), Cells(Fin + 3, 6)).Interior
.Color = 5296274
End With
With Range(Cells(Fin + 3, 5), Cells(Fin + 3, 6))
.BorderAround Weight:=xlMedium
End With
Exit Sub
End If
GoTo Retour
End Sub
je souhaiterais ameliorer le code vba ci dessous afin d ' eviter le message d ' alerte 'autorisation d ' excel avant d effectuer l ' envoie automatique d ' email via outlook lors de l execution de ma macro.
Aussi serait t ' il possible de rajouter dans le corp de mon courriel le message " Salu." .
je vous remercie d ' avance pour votre aide
LGVBA
Dim Destinataire As String, Sujet As String
'Dim AccuseReception As Boolean
Destinataire = Adresse_courriel
Sujet = "Décompte personnel"
ThisWorkbook.Sheets("Base courriel").Copy
ActiveWorkbook.SendMail Destinataire, Sujet
ActiveWorkbook.Close False
Mon code vba en entier
Sub aaa()
Dim Début As Integer, Fin As Integer, Grand_total As Currency, ID_traité As String, Nom_traité As String
Dim feuillenom As String, i As Integer, Adresse_courriel As String
Application.ScreenUpdating = False
feuillenom = Date '& " - " & Hour(Time) & "h " & Minute(Time) & "m"
Sheets("Base").Copy After:=Sheets(1)
'Sheets("Base2").Name = feuillenom
Columns("F:F").NumberFormat = "#,##0.00"
ActiveSheet.Shapes("Button 1").Delete
Range("A2").Activate
Retour:
ID_traité = ActiveCell
Nom_traité = ActiveCell.Offset(0, 1)
With Sheets("Adresses électroniques")
For i = 2 To .Range("A65000").End(xlUp).Row
If .Cells(i, 1) = ID_traité And .Cells(i, 2) = Nom_traité Then Adresse_courriel = .Cells(i, 3)
Next i
End With
Début = ActiveCell.Row
Do Until ActiveCell <> ID_traité Or ActiveCell.Offset(0, 1) <> Nom_traité
ActiveCell.Offset(1, 0).Activate
Loop
Fin = ActiveCell.Row - 1
Rows(Fin + 1 & ":" & Fin + 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(ActiveCell.Row, 5) = "Total"
Cells(ActiveCell.Row, 6) = WorksheetFunction.Sum(Range(Cells(Début, 6), Cells(Fin, 6)))
Grand_total = Grand_total + Cells(ActiveCell.Row, 6)
Range(Cells(ActiveCell.Row, 5), Cells(ActiveCell.Row, 6)).Font.Bold = True
With Range(Cells(ActiveCell.Row, 5), Cells(ActiveCell.Row, 6)).Interior
.Color = 5296274
End With
With Range(Cells(ActiveCell.Row, 5), Cells(ActiveCell.Row, 6))
.BorderAround Weight:=xlMedium
End With
With Range(Cells(ActiveCell.Row + 1, 1), Cells(ActiveCell.Row + 1, 6)).Interior
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.349986266670736
End With
Range(Cells(Début, 1), Cells(Fin, 6)).Borders.Weight = xlThin
'Report individuel sur feuille "Base courriel"
With Sheets("Base courriel")
.Range("A2:F65000").Delete
Range(Cells(Début, 1), Cells(Fin + 1, 6)).Copy Destination:=.Range("A2")
End With
Dim Destinataire As String, Sujet As String
Dim AccuseReception As Boolean
Destinataire = Adresse_courriel
Sujet = "Détail Prélevement Bancaire"
ThisWorkbook.Sheets("Base courriel").Copy
ActiveWorkbook.SendMail Destinataire, Sujet
ActiveWorkbook.Close False
ActiveCell.Offset(2, 0).Activate
If ActiveCell = "" Then
Cells(Fin + 3, 5) = "Grand Total"
Cells(Fin + 3, 6) = Grand_total
Range(Cells(Fin + 3, 5), Cells(Fin + 3, 6)).Font.Bold = True
With Range(Cells(Fin + 3, 5), Cells(Fin + 3, 6)).Interior
.Color = 5296274
End With
With Range(Cells(Fin + 3, 5), Cells(Fin + 3, 6))
.BorderAround Weight:=xlMedium
End With
Exit Sub
End If
GoTo Retour
End Sub