attach different worksheet and email them tdifferent email address through macro/vba/addin

Hi All,

I am seeking code sample or tips to help with the following:

Workbook 1 contains a organization and email addresses for the organization.
Organization Email address
0170 abc0170@www.cpo
0171 abc0171@www.cpo

Workbook2 contains a separate worksheet (worksheet name would be 0170, 0171 etc) for each organization and I have a folder on my desktop that contains files (file names would be 0170.xls, 0171.xls, etc) for each organization.

What I am trying to do is send an email to each address in workbook 1 that contains the worksheet or file for that organization - file name or worksheet name matches the org name in workbook 1.

Try this...
youd have to tweek the code to add your folders and subject, body.

Put this in a module in the workbook1 with the emails list.
Add a button to the screen to run the macro: SendXlEmails

Option Explicit
'by Ranman256
Private mEwb As Workbook

Public Sub SendXlEmails()
  Set mEwb = ActiveWorkbook
  
 EmailAllFilesInDir "\\myfolder\myFolder2\"
 
  Set mEwb = Nothing
End Sub

Private Sub EmailAllFilesInDir(ByVal pvDir)
Dim vFil
Dim i As Integer
Dim fso
Dim oFolder, oFile

On Error GoTo errImp
If Right(pvDir, 1) <> "\" Then pvDir = pvDir & "\"

Set fso = CreateObject("Scripting.FileSystemObject")
Set oFolder = fso.GetFolder(pvDir)

For Each oFile In oFolder.Files
    vFil = pvDir & oFile.Name
                                'ONLY DO EXCEL FILES
    If InStr(vFil, ".xls") > 0 Then
    CollectEmails pvDir, oFile.Name
    End If
Next

Set fso = Nothing
Set oFile = Nothing
Set oFolder = Nothing
Exit Sub

errImp:
MsgBox Err.Description, vbCritical, "EmailAllFilesInDir()" & Err
Exit Sub
Resume
End Sub

Private Sub CollectEmails(ByVal pvDir, ByVal pvFile)
Dim vTo, vSubj, vBody
Dim vCode, vDir, vFullFile
Dim i As Long

'================
    'send 1 email having everyones address code
'================
vFullFile = pvDir & pvFile
i = InStr(pvFile, ".x")
vCode = Left(pvFile, i - 1)

mEwb.Activate
Range("A1").Select          'assumes the codes are in Col A and...

While ActiveCell.Value <> ""
   If ActiveCell.Value = vCode Then vTo = vTo & ActiveCell.Offset(0, 1).Value & ";"       '... emails Col B
   
   ActiveCell.Offset(1, 0).Select       'NEXT ROW
Wend
  
vSubj = "My subject"
  
'-------
'YOU MUST ADD THE OUTLOOK OBJECT LIB in vbe, TOOLS, REFERENCES!!!   checkmark OUTLOOK OBJECTS in the vbE menu, Tools, References
'-------
MsgBox "add OUTLOOK to references", , "Then delete this msgbox"

Send1Email vTo, "My subject", vBody, vFullFile          'SEND EMAIL

End Sub



Public Function Send1Email(ByVal pvTo, ByVal pvSubj, ByVal pvBody, Optional pvFile) As Boolean
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem

On Error GoTo ErrMail

Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(olMailItem)

With oMail
    .To = pvTo
    .Subject = pvSubj
    .Body = pvBody

    If Not IsMissing(pvFile) Then .Attachments.Add pvFile, olByValue, 1
    
   .Send
End With

Send1Email = True
Set oMail = Nothing
Set oApp = Nothing
Exit Function

ErrMail:
MsgBox Err.Description, vbCritical, Err
Resume Next
End Function

Dear Ranman256,

I have attached my two excel workbook. In "email" workbook I have recipients name to whom I want to email and in "Data to email" I have many worksheets in the same order as per "email" workbook. Please guide me how to email "0001" worksheet to "0001@abc.co" ; "0008" worksheet to "0008@abc.co" in one command.

I have run your module in my "email" workbook but not able to get the result.
I can convert/split all the worksheets into workbook with the same name.

Please help.

I cannot attach the workbook for some reason. Send me an email address to send it to.

email2.xls

working macro.