Envoyer par email un onglet selon critères

nagoya

XLDnaute Nouveau
hello!

je ne trouve pas mon bonheur online, alors voilà ma demande.

j'ai un fichier avec 4 onglets
1)onglet 1 = SOURCE avec en colonne A: le departement et b: email du departement
2)onglet 2 = Dep A pour departement A
3)onglet 3 = Dep B pour departement B
4)onglet 4 = Dep C pour department C

je souhaite avec une macro envoyer un email à chaque département avec son onglet attaché. L'onglet source permettant de définir l'email (une sorte de vlookup sur le nom de l'onglet pour définir l'email d'envoi). Dans la source le nom du departement = un onglet pour trouver l'email

Merci de votre aide!
 

Pièces jointes

  • exple.xlsx
    9.4 KB · Affichages: 25
  • exple.xlsx
    9.4 KB · Affichages: 26
Dernière édition:

nagoya

XLDnaute Nouveau
Re : Envoyer par email un onglet selon critères

up .
hello!

je ne trouve pas mon bonheur online, alors voilà ma demande.

j'ai un fichier avec 4 onglets
1)onglet 1 = SOURCE avec en colonne A: le departement et b: email du departement
2)onglet 2 = Dep A pour departement A
3)onglet 3 = Dep B pour departement B
4)onglet 4 = Dep C pour department C

je souhaite avec une macro envoyer un email à chaque département avec son onglet attaché. L'onglet source permettant de définir l'email (une sorte de vlookup sur le nom de l'onglet pour définir l'email d'envoi). Dans la source le nom du departement = un onglet pour trouver l'email

Merci de votre aide!
 

nagoya

XLDnaute Nouveau
Re : Envoyer par email un onglet selon critères

la solution trouvée sur internet pour cloturer le fil.

Option Explicit

'---------------------------------------------------------------------------------------
' Procedure : send_mails_for_workbook
' Author : Charlize
' Date : 1/09/2008
' Purpose : Process every sheet in workbook exept 'Master Sheet' and 'Data'
'---------------------------------------------------------------------------------------
'
Sub send_mails_for_workbook()
'workbook
Dim mywb As Workbook
'worksheet
Dim mysheet As Worksheet
'name of worksheet we look for to get emailaddress
Dim myvalue As Range
'the mailaddress
Dim mymailaddress As String
Set mywb = ActiveWorkbook
'For each sheet in workbook exept Master Sheet and Data
For Each mysheet In mywb.Worksheets
If mysheet.Name <> "Master Sheet" And _
mysheet.Name <> "Data" Then
'Define the range where we need to look for name
With mywb.Worksheets("Master Sheet").Range("A2:A" & _
mywb.Worksheets("Master Sheet").Range("A" & _
Rows.Count).End(xlUp).Row)
'Search for name
Set myvalue = .Find(mysheet.Name, LookIn:=xlValues)
'if name is found
If Not myvalue Is Nothing Then
'store offset value in string
mymailaddress = myvalue.Offset(, 1).Value
'change this line with your routine for sending mail
'MsgBox "Send mail for " & mysheet.Name & vbCrLf & _
"at " & mymailaddress
'Function created from coding provided by
'Ron De Bruin on his website. With a little
'tweak here and there. For the moment it will
'display the mails. Change to .Send in function
'if you want to send them immediately.
Call Mail_Sheet(mysheet.Name, mymailaddress)
End If
End With
End If
'go on with next sheet
Next mysheet
End Sub


'---------------------------------------------------------------------------------------
' Procedure : Mail_Sheet
' DateTime : 04/09/2008 11:33
' Author : Charlize
' (modified routine from Ron de Bruin :
' Excel Automation - Ron de Bruin)
' Purpose : Mail the specified sheet to the specified mailaddress
' There is no errorchecking regarding the mailaddress
' ie. there must be a mailaddress for each sheet
'---------------------------------------------------------------------------------------
'
Function Mail_Sheet(myworksheetname As String, mymail As String)
'Working in 2000-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set Sourcewb = ActiveWorkbook

'Copy the sheet to a new workbook
Sourcewb.Worksheets(myworksheetname).Copy
Set Destwb = ActiveWorkbook

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
'We exit the sub when your answer is NO in the security dialog that you only
'see when you copy a sheet from a xlsm file with macro's disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Function
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Part of " & Sourcewb.Name & " " & _
Format(Now, "dd-mmm-yy h-mm-ss")

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
'mailaddres you passed to this routine
.to = mymail
.CC = ""
.BCC = ""
.Subject = "xxxx"
.Body = "Hello," & _
"," & vbCrLf & vbCrLf & _
"Please xxxx." & _
vbCrLf & vbCrLf & "Best Regards," & vbCrLf
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
'.Send or use .Display
.Display
End With
On Error GoTo 0
.Close SaveChanges:=False
End With

'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Function
 

Discussions similaires

Réponses
2
Affichages
311