Macro excel pour envoyer mail avec insertion
Fermé
speedcomputer
Messages postés
9
Date d'inscription
lundi 28 avril 2008
Statut
Membre
Dernière intervention
17 juin 2008
-
17 juin 2008 à 10:57
EVD46 - 2 sept. 2008 à 12:54
EVD46 - 2 sept. 2008 à 12:54
Bonjour,
je recherche à completer ma ligne de code ci dessous pour inserer une 2 eme adresse et du texte
Application.Dialogs(xlDialogSendMail).Show adressemail, monobjetmail
merci
je recherche à completer ma ligne de code ci dessous pour inserer une 2 eme adresse et du texte
Application.Dialogs(xlDialogSendMail).Show adressemail, monobjetmail
merci
A voir également:
- Outloouk
- Telecharger macro convertir chiffre en lettre excel - Télécharger - Tableur
- Liste déroulante excel - Guide
- Gmail envoyer un mail - Guide
- Word et excel gratuit - Guide
- Formule excel pour additionner plusieurs cellules - Guide
2 réponses
J'ai développé le code ci-après pour envoyer à plusieurs destinataires un fichier Excel d'adhérents à une association - auquel de nouveaux sont donc régulièrement ajoutés - après l'avoir "sorted", puis enlevé d'éventuels doubles, redéfini la zone à imprimer, sauvegardé à différents endroits avec un nom mis à jour en fonction de l'ordinateur sur lequel l'application tourne:
Sub Kopier_naar_Mijn_gegevensbronnen()
' afdruk_bereik Macro
' De macro is opgenomen op 12/03/2008 door Erik.
'
Dim OldFn As String, ShortFn As String, NewFn As String, DirDest1 As String, DirDest2 As String
Dim RowNumber As Integer
Dim MailAd As Variant
'
' Cachez l'écran
Application.DisplayAlerts = False
' Sort
Range("N2").Select
Selection.End(xlDown).Select
RowNumber = ActiveCell.Row
RRange = "A2:BA" & RowNumber & ""
Range(RRange).Sort Key1:=Range("N2"), Order1:=xlAscending, Key2:=Range _
("O2"), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase _
:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
DataOption2:=xlSortNormal
'
' Cherchez doubles
n = 957 '2
While Range("N" & n) <> ""
Range("N" & n).Select
If (LCase(Range("N" & n) & Range("O" & n)) = LCase(Range("N" & n - 1) & Range("O" & n - 1))) Or (Range("V" & n) <> "" And LCase(Range("V" & n)) = LCase(Range("V" & n - 1))) Then
RowNumber = ActiveCell.Row
RRange = "N" & RowNumber & ""
Range(RRange).Select
MsgBox "Un double est à éliminer à la rangée " & RowNumber & "."
Stop
End If
n = n + 1
Wend
'
' Sélectionnez printarea
Range("N2").Select
Selection.End(xlDown).Select
RowNumber = ActiveCell.Row
Range("AG" & RowNumber).Select
Range(Selection, Selection.End(xlUp)).Select
Range(Selection, Selection.End(xlToRight)).Select
ActiveSheet.PageSetup.PrintArea = "$AG$1:$AL$" & RowNumber
Range("N2").Select
'
' Kopier ongedateerd naar "Mijn Gegevensbronnen"
OldFn = ActiveWorkbook.Name
ShortFn = Left(OldFn, Len(OldFn) - 11) & ".xls"
NewFn = Left(ShortFn, Len(ShortFn) - 4) & "_" & Format(Date, "yymmdd") & ".xls"
' MsgBox "L'ancien fichier s'appelait " & oldfn & ", la racine en est " & shortfn & " et le nouveau fichier s'appellera " & newfn
' MsgBox "L'ordinateur s'appelle " & Application.UserName & "."
If Application.UserName = "Erik" Then
DirDest1 = "C:\Documents and Settings\Erik\Mes documents\Mijn gegevensbronnen\"
DirDest2 = "C:\Documents and Settings\Erik\Mes documents\Orgues\Adhérents\"
MailAd = Array("hhh@club-internet.fr", "ccc@neuf.fr")
End If
If Application.UserName = "Hilde Pernet" Then
DirDest1 = "C:\Documents and Settings\HP\Mes documents\Mijn gegevensbronnen\"
DirDest2 = "C:\Documents and Settings\HP\Mes documents\Orgues\Adhérents\"
MailAd = Array("eee@club-internet.fr", "ccc@neuf.fr")
End If
If Application.UserName = "Claude" Then
DirDest1 = "C:\Documents and Settings\Claude\Mes documents\Mes sources de données\"
DirDest2 = "C:\Documents and Settings\Claude\Mes documents\Orgues\Adhérents\"
MailAd = Array("eee@club-internet.fr", "hhh@club-internet.fr")
End If
' Copier le fichier à DirDest1 et DirDest2
' MsgBox "Le fichier " & ShortFn & " sera bientôt enregistré sur " & DirDest1 & "."
On Error Resume Next: MkDir DirDest1
On Error Resume Next: ActiveWorkbook.SaveAs Filename:=DirDest1 & ShortFn, ReadOnlyRecommended:=True
On Error Resume Next: MkDir DirDest2
On Error Resume Next: ActiveWorkbook.SaveAs Filename:=DirDest2 & NewFn, ReadOnlyRecommended:=False, AddToMru:=True
Application.DisplayAlerts = True
' Envois par courriel
On Error Resume Next
' MsgBox "Le fichier " & newfn & " sera bientôt envoyé au Président, à la Secrétaire et au Trésorier." & vbCrLf & "Effacez dans la liste des destinataires votre propre adresse."
Application.Dialogs(xlDialogSendMail).Show MailAd
'
End Sub
Sub Kopier_naar_Mijn_gegevensbronnen()
' afdruk_bereik Macro
' De macro is opgenomen op 12/03/2008 door Erik.
'
Dim OldFn As String, ShortFn As String, NewFn As String, DirDest1 As String, DirDest2 As String
Dim RowNumber As Integer
Dim MailAd As Variant
'
' Cachez l'écran
Application.DisplayAlerts = False
' Sort
Range("N2").Select
Selection.End(xlDown).Select
RowNumber = ActiveCell.Row
RRange = "A2:BA" & RowNumber & ""
Range(RRange).Sort Key1:=Range("N2"), Order1:=xlAscending, Key2:=Range _
("O2"), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase _
:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
DataOption2:=xlSortNormal
'
' Cherchez doubles
n = 957 '2
While Range("N" & n) <> ""
Range("N" & n).Select
If (LCase(Range("N" & n) & Range("O" & n)) = LCase(Range("N" & n - 1) & Range("O" & n - 1))) Or (Range("V" & n) <> "" And LCase(Range("V" & n)) = LCase(Range("V" & n - 1))) Then
RowNumber = ActiveCell.Row
RRange = "N" & RowNumber & ""
Range(RRange).Select
MsgBox "Un double est à éliminer à la rangée " & RowNumber & "."
Stop
End If
n = n + 1
Wend
'
' Sélectionnez printarea
Range("N2").Select
Selection.End(xlDown).Select
RowNumber = ActiveCell.Row
Range("AG" & RowNumber).Select
Range(Selection, Selection.End(xlUp)).Select
Range(Selection, Selection.End(xlToRight)).Select
ActiveSheet.PageSetup.PrintArea = "$AG$1:$AL$" & RowNumber
Range("N2").Select
'
' Kopier ongedateerd naar "Mijn Gegevensbronnen"
OldFn = ActiveWorkbook.Name
ShortFn = Left(OldFn, Len(OldFn) - 11) & ".xls"
NewFn = Left(ShortFn, Len(ShortFn) - 4) & "_" & Format(Date, "yymmdd") & ".xls"
' MsgBox "L'ancien fichier s'appelait " & oldfn & ", la racine en est " & shortfn & " et le nouveau fichier s'appellera " & newfn
' MsgBox "L'ordinateur s'appelle " & Application.UserName & "."
If Application.UserName = "Erik" Then
DirDest1 = "C:\Documents and Settings\Erik\Mes documents\Mijn gegevensbronnen\"
DirDest2 = "C:\Documents and Settings\Erik\Mes documents\Orgues\Adhérents\"
MailAd = Array("hhh@club-internet.fr", "ccc@neuf.fr")
End If
If Application.UserName = "Hilde Pernet" Then
DirDest1 = "C:\Documents and Settings\HP\Mes documents\Mijn gegevensbronnen\"
DirDest2 = "C:\Documents and Settings\HP\Mes documents\Orgues\Adhérents\"
MailAd = Array("eee@club-internet.fr", "ccc@neuf.fr")
End If
If Application.UserName = "Claude" Then
DirDest1 = "C:\Documents and Settings\Claude\Mes documents\Mes sources de données\"
DirDest2 = "C:\Documents and Settings\Claude\Mes documents\Orgues\Adhérents\"
MailAd = Array("eee@club-internet.fr", "hhh@club-internet.fr")
End If
' Copier le fichier à DirDest1 et DirDest2
' MsgBox "Le fichier " & ShortFn & " sera bientôt enregistré sur " & DirDest1 & "."
On Error Resume Next: MkDir DirDest1
On Error Resume Next: ActiveWorkbook.SaveAs Filename:=DirDest1 & ShortFn, ReadOnlyRecommended:=True
On Error Resume Next: MkDir DirDest2
On Error Resume Next: ActiveWorkbook.SaveAs Filename:=DirDest2 & NewFn, ReadOnlyRecommended:=False, AddToMru:=True
Application.DisplayAlerts = True
' Envois par courriel
On Error Resume Next
' MsgBox "Le fichier " & newfn & " sera bientôt envoyé au Président, à la Secrétaire et au Trésorier." & vbCrLf & "Effacez dans la liste des destinataires votre propre adresse."
Application.Dialogs(xlDialogSendMail).Show MailAd
'
End Sub
2 sept. 2008 à 10:20
Belle appli, tu pourrais peut-être un peu l'optimiser Avec cette astuce
A+
2 sept. 2008 à 12:54
Cordialement.
Erik