Email Workbooks based on Workbook name to different addresses

Question

I have code that opens a dialog box that allows a user to select an Excel sheet, filters the country column (11), copies and pastes that country into a new workbook, names the new workbook after that country, repeats the action for the next country, saves and closes each Workbook.

Currently before it closes the workbook it sends the newly created workbooks to my email address.

I want if the workbook is named "Belgium" email to [email protected], if the Workbook is named "Bulagria" email to [email protected] and so on. Different countries get emailed to different addresses.

My Email CODE is here

Public Sub Mail_workbook_Outlook_1()
'Working in Excel 2000-2016
'This example send the last saved version of the Activeworkbook
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim OutMail As Object

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

    On Error Resume Next
    With OutMail
        .to = "[email protected]"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .Body = "Hi there"
        .Attachments.Add ActiveWorkbook.FullName
        'You can add other files also like this
        '.Attachments.Add ("C:\test.txt")
        .Send   'or use .Display
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

MAIN BODY OF CODE

Sub Open_Workbook_Dialog()

Dim my_FileName As Variant
Dim my_Workbook As Workbook

  MsgBox "Pick your CRO file" '<--| txt box for prompt to pick a file

  my_FileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*") '<--| Opens the file window to allow selection

  If my_FileName <> False Then
    Set my_Workbook = Workbooks.Open(Filename:=my_FileName)

    Call TestThis

    Call Filter(my_Workbook) '<--|Calls the Filter Code and executes

  End If
End Sub

Public Sub Filter(my_Workbook As Workbook)
  Dim rCountry As Range, helpCol As Range
  Dim wb As Workbook
  With my_Workbook.Sheets(1) '<--| refer to data worksheet
    With .UsedRange
      Set helpCol = .Resize(1, 1).Offset(, .Columns.Count) '<--| get a "helper" column just at the right of used range, it'll be used to store unique country names in
    End With

   With .Range("A1:Y" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<--| refer to its columns "A:Y" from row 1 to last non empty row of column "A"
            .Columns(11).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=helpCol, Unique:=True '<-- call AdvancedFilter on 11th column of the referenced range and store its unique values in "helper" column
            Set helpCol = Range(helpCol.Offset(1), helpCol.End(xlDown)) '<--| set range with unique names in (skip header row)
            For Each rCountry In helpCol '<--| iterate over unique country names range (skip header row)
                .AutoFilter 11, rCountry.Value2 '<--| filter data on country field (11th column) with current unique country name
                If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then '<--| if any cell other than header ones has been filtered...
                    Set wb = Application.Workbooks.Add '<--... add new Workbook
                        wb.SaveAs Filename:="C:\Users\CONNELLP\Desktop\Claire Macro\CRO Countries\" & rCountry.Value2 '<--... saves the workbook after the country
                            .SpecialCells(xlCellTypeVisible).Copy wb.Sheets(1).Range("A1")
                               ActiveSheet.Name = rCountry.Value2  '<--... rename it
                           .SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Range("A1") 'copy data for country under header
                           Sheets(1).Range("A1:Y1").WrapText = False 'Takes the wrap text off
                           ActiveWindow.Zoom = 55 'Zooms out the window
                         Sheets(1).UsedRange.Columns.AutoFit 'Autofits the column
                    ActiveWorkbook.Save '<--... saves and closes workbook
                    Call Mail_workbook_Outlook_1
                    wb.Close SaveChanges:=True '<--... saves and closes workbook
                End If
            Next
        End With
        .AutoFilterMode = False '<--| remove autofilter and show all rows back
    End With
    helpCol.Offset(-1).End(xlDown).Clear '<--| clear helper column (header included)
End Sub

Public Sub TestThis()
Dim wks As Worksheet

Set wks = ActiveWorkbook.Sheets(1)

With wks
.AutoFilterMode = False
.Range("A:K").AutoFilter Field:=11, Criteria1:="<>", Operator:=xlFilterValues
.Range("A:C").SpecialCells(xlCellTypeBlanks).Interior.Color = 65535
.AutoFilterMode = False
End With
End Sub

Public Sub Mail_workbook_Outlook_1()
'Working in Excel 2000-2016
'This example send the last saved version of the Activeworkbook
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim OutMail As Object

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

    On Error Resume Next
    With OutMail
        .to = "[email protected]"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .Body = "Hi there"
        .Attachments.Add ActiveWorkbook.FullName
        'You can add other files also like this
        '.Attachments.Add ("C:\test.txt")
        .Send   'or use .Display
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Picture of Original

Pic of Countries Sheet

Answer 1

try following these steps

• in Public Sub Filter(my_Workbook As Workbook), add

  Dim outApp As Object '<-- declare the object where to store Outlook application reference
  Dim addrRng As Range
  

  between declarations

• in Public Sub Filter(my_Workbook As Workbook) add

  Set outApp = GetOutlook
  

  just before

  With my_Workbook.Sheets(1) '<--| refer to data worksheet
  

• in Public Sub Filter(my_Workbook As Workbook), add

              Set addrRng = GetCountryAddressRange(.Parent.Parent.Worksheets("countries"), rCountry.Value2) '<-- try getting passed country name in worksheet "countries"
              If addrRng Is Nothing Then '<--| if country not found, inform the user
                  MsgBox "Sorry, " & rCountry.Value2 & " not found in worksheet 'countries'" & vbCrLf & vbCrLf _
                  & "no mail will be sent", vbInformation
              Else '<--| if  found, send the email
                  Call Mail_workbook_Outlook_1(outApp, addrRng)
              End If
  

  between

  ActiveWorkbook.Save '<--... saves and closes workbook
  

  and

  wb.Close SaveChanges:=True '<--... saves and closes workbook
  

• in Public Sub Filter(my_Workbook As Workbook), add

  outApp.Quit '<-- close outlook
  Set outApp = Nothing
  

  just before End Sub

• modify Mail_workbook_Outlook_1 as follows

  Public Sub Mail_workbook_Outlook_1(outApp As Object, addrRng As Range)
  
      With outApp.CreateItem(0)
          .to = addrRng.text '<-- email in found cell content
          .CC = ""
          .BCC = ""
          .Subject = addrRng.Offset(, 1).text '<-- subject in cell one column right of found one
          .Body = addrRng.Offset(, 2).text '<-- subject in cell two column right of found one
          .Attachments.Add ActiveWorkbook.FullName
          'You can add other files also like this
          '.Attachments.Add ("C:\test.txt")
          .Send   'or use .Display
      End With
  End Sub
  

• add the following functions in any module

  Function GetCountryAddressRange(ws As Worksheet, name As String) As Range
      Dim f As Range
      With ws
          Set f = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Find(what:=name, LookIn:=xlValues, lookat:=xlWhole)
      End With
      If Not f Is Nothing Then Set GetCountryAddressRange = f.Offset(, 1)
  End Function
  
  
  Function GetOutlook() As Object
      Set GetOutlook = GetObject(, "Outlook.Application")
      If GetOutlook Is Nothing Then Set GetOutlook = CreateObject("Outlook.Application")
  End Function
  

Answer 2

The easiest way would be using a "select case" statement and passing the return value to Mail_workbook_Outlook_1 as parameter.

Function GetMailAddress(country as string) as string
    Select Case country
        Case country1 GetMailAddress = address1
        Case country2 GetMailAddress = address2
        Case else GetMailAddress = address3
    End Select
End Function

Of course, it would make sense to store the information somewhere where it is easier to modify, a Countries-Sheet in your master-file / addin maybe.

Function GetMailAddress(country as string) as string
    dim countriesSheet as worksheet
    set countriesSheet = Sheets("Countries")
    dim i as long
    do while countriesSheet.cells(i,1) <> ""
        if countriesSheet.cells(i,1) = country then
          GetMailAddress = countriesSheet.cells(i,2)
          exit function
        end if
        i = i+1

    loop
    GetMailAddress = "yourdefaultaddress"
End Function