Email Workbooks based on Workbook name to different addresses - vba

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 Jane.Doe#email.com, if the Workbook is named "Bulagria" email to John.Doe#Email.com 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 = "philip.connell#email.com"
.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 = "Philip.Connell#email.com"
.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