Email a List based on a criteria to the Email address in another workbook

[mikemakany]

Hi,
I have 2 workbooks, one with Emp ID and Position and one with Position and Email address. Is it possible to send each list as a workbook based on the position and ID in workbook 1 to the corresponding email address that is in workbook 2 using a macro?
Thank you all
Mike


▬▬▬▬▬▬▬▬▬ Mod edit : thread moved to appropriate forum !

​

 

[Kenneth Hobson]

Yes.

What does the list look like? Is it a filtered list from workbook1 with the ID and position based on each position listed in workbook2? If so, does a workbook need to be created and attached or would a copy of the "list" embedded in the email body be better? Lastly, run the macro from which workbook?

 

[mikemakany]

Hi Kenneth,
Thanks for the reply. The workbook 2 will be having all the email addresses and will be in a folder. And workbook 1 will be saved in the same folder at a certain time. The macro can be in workbook 2 and I will schedule the macro to run at a certain time after workbook 1 gets saved in the folder using vb script. The macro has to create a workbook for each position and then it has to be attached to the corresponding positions email which is in the workbook 2. Please let me know if you want more details.
Thanks
Mike

 

[Kenneth Hobson]

'Add reference: Microsoft Outlook xx.x Library, where xx.x is 14.0, 15.0, 16.0, etc.
Sub Main()
  Dim olApp As Outlook.Application, olMail As Outlook.MailItem
  Dim a, e, r As Range, c As Range
  Dim wb1 As Workbook, wb1Path As String, wb2 As Workbook
  Dim ws1 As Worksheet, ws2 As Worksheet
  Dim PathA As String, wbA As Workbook, wbAname As String
  'Path to store filtered workbooks to attach
  PathA = Environ("temp") & "\"
  PathA = ThisWorkbook.Path & "\"
  wb1Path = ThisWorkbook.Path & "\Work Book 1.xlsx"
  If Len(Dir(wb1Path)) = 0 Then Exit Sub
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
  Application.DisplayAlerts = False
  'On Error GoTo TheEnd
  Set wb1 = Workbooks.Open(wb1Path)
  Set wb2 = ThisWorkbook
  Set ws1 = wb1.Worksheets(1)
  Set ws2 = wb2.Worksheets(1)
  Set olApp = New Outlook.Application
  Set r = ws2.Range("A2", ws2.Range("A2").End(xlDown))
  For Each c In r
    ws1.UsedRange.AutoFilter 2, c.Value
    ws1.UsedRange.SpecialCells(xlCellTypeVisible).Copy
    Set wbA = Workbooks.Add
    wbA.Worksheets(1).Range("A1").PasteSpecial
    Application.CutCopyMode = False
    wbA.Worksheets(1).UsedRange.EntireColumn.AutoFit
    wbAname = PathA & c.Value & ".xlsx"
    wbA.SaveAs wbAname, xlOpenXMLWorkbook
    wbA.Close False
   
    Set olMail = olApp.CreateItem(olMailItem)
    With olMail
      .To = c.Offset(, 1).Value
      .Subject = c.Value & " List Attached"
      .Body = "See Attachment"
      .Attachments.Add wbAname
      .Display
      '.Send
    End With
    Kill wbAname
  Next c
  On Error Resume Next
TheEnd:
  wb1.Close False
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic
  Application.DisplayAlerts = True
  Set olMail = Nothing
  Set olApp = Nothing
End Sub

 

[mikemakany]

Hi Kenneth,
You saved a lot of time for me. The macro worked like a charm. Thanks a lot.
Cheers
Mike