excel - Email Workbooks based on Workbook name to different addresses -

i have code opens dialog box allows user select excel sheet, filters country column (11), copies , pastes country new workbook, names new workbook after country, repeats action next country, saves , closes each workbook.

currently before closes workbook sends newly created workbooks email address.

i want if workbook named "belgium" email jane.doe@email.com, if workbook named "bulagria" email john.doe@email.com , on. different countries emailed different addresses.

my email code here

public sub mail_workbook_outlook_1() 'working in excel 2000-2016 'this example send last saved version of activeworkbook 'for tips see: http://www.rondebruin.nl/win/winmail/outlook/tips.htm     dim outapp object     dim outmail object      set outapp = createobject("outlook.application")     set outmail = outapp.createitem(0)      on error resume next     outmail         .to = "philip.connell@email.com"         .cc = ""         .bcc = ""         .subject = "this subject line"         .body = "hi there"         .attachments.add activeworkbook.fullname         'you can add other files         '.attachments.add ("c:\test.txt")         .send   'or use .display     end     on error goto 0      set outmail = nothing     set outapp = nothing end sub 

main body of code

sub open_workbook_dialog()  dim my_filename variant dim my_workbook workbook    msgbox "pick cro file" '<--| txt box prompt pick file    my_filename = application.getopenfilename(filefilter:="excel files,*.xl*;*.xm*") '<--| opens file window allow selection    if my_filename <> false     set my_workbook = workbooks.open(filename:=my_filename)      call testthis      call filter(my_workbook) '<--|calls filter code , executes    end if end sub  public sub filter(my_workbook workbook)   dim rcountry range, helpcol range   dim wb workbook   my_workbook.sheets(1) '<--| refer data worksheet     .usedrange       set helpcol = .resize(1, 1).offset(, .columns.count) '<--| "helper" column @ right of used range, it'll used store unique country names in     end     .range("a1:y" & .cells(.rows.count, 1).end(xlup).row) '<--| refer columns "a:y" row 1 last non empty row of column "a"             .columns(11).advancedfilter action:=xlfiltercopy, copytorange:=helpcol, unique:=true '<-- call advancedfilter on 11th column of referenced range , store unique values in "helper" column             set helpcol = range(helpcol.offset(1), helpcol.end(xldown)) '<--| set range unique names in (skip header row)             each rcountry in helpcol '<--| iterate on unique country names range (skip header row)                 .autofilter 11, rcountry.value2 '<--| filter data on country field (11th column) current unique country name                 if application.worksheetfunction.subtotal(103, .cells.resize(, 1)) > 1 '<--| if cell other 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 workbook after country                             .specialcells(xlcelltypevisible).copy wb.sheets(1).range("a1")                                activesheet.name = rcountry.value2  '<--... rename                            .specialcells(xlcelltypevisible).copy activesheet.range("a1") 'copy data country under header                            sheets(1).range("a1:y1").wraptext = false 'takes wrap text off                            activewindow.zoom = 55 'zooms out window                          sheets(1).usedrange.columns.autofit 'autofits column                     activeworkbook.save '<--... saves , closes workbook                     call mail_workbook_outlook_1                     wb.close savechanges:=true '<--... saves , closes workbook                 end if             next         end         .autofiltermode = false '<--| remove autofilter , show rows     end     helpcol.offset(-1).end(xldown).clear '<--| clear helper column (header included) end sub  public sub testthis() dim wks worksheet  set wks = activeworkbook.sheets(1)  wks .autofiltermode = false .range("a:k").autofilter field:=11, criteria1:="<>", operator:=xlfiltervalues .range("a:c").specialcells(xlcelltypeblanks).interior.color = 65535 .autofiltermode = false end end sub  public sub mail_workbook_outlook_1() 'working in excel 2000-2016 'this example send last saved version of activeworkbook 'for tips see: http://www.rondebruin.nl/win/winmail/outlook/tips.htm     dim outapp object     dim outmail object      set outapp = createobject("outlook.application")     set outmail = outapp.createitem(0)      on error resume next     outmail         .to = "philip.connell@email.com"         .cc = ""         .bcc = ""         .subject = "this subject line"         .body = "hi there"         .attachments.add activeworkbook.fullname         'you can add other files         '.attachments.add ("c:\test.txt")         .send   'or use .display     end     on error goto 0      set outmail = nothing     set outapp = nothing end sub 

picture of original

pic of countries sheet

try following these steps

• in public sub filter(my_workbook workbook), add

  dim outapp object '<-- declare object store outlook application reference dim addrrng range 

  between declarations

• in public sub filter(my_workbook workbook) add

  set outapp = getoutlook 

  just before

  with my_workbook.sheets(1) '<--| refer data worksheet 

• in public sub filter(my_workbook workbook), add

              set addrrng = getcountryaddressrange(.parent.parent.worksheets("countries"), rcountry.value2) '<-- try getting passed country name in worksheet "countries"             if addrrng nothing '<--| if country not found, inform user                 msgbox "sorry, " & rcountry.value2 & " not found in worksheet 'countries'" & vbcrlf & vbcrlf _                 & "no mail sent", vbinformation             else '<--| if  found, send email                 call mail_workbook_outlook_1(outapp, addrrng)             end if 

  between

  activeworkbook.save '<--... saves , closes workbook 

  and

  wb.close savechanges:=true '<--... saves , closes workbook 

• in public sub filter(my_workbook workbook), add

  outapp.quit '<-- close outlook set outapp = nothing 

  just before end sub

• modify mail_workbook_outlook_1 follows

  public sub mail_workbook_outlook_1(outapp object, addrrng range)      outapp.createitem(0)         .to = addrrng.text '<-- email in found cell content         .cc = ""         .bcc = ""         .subject = addrrng.offset(, 1).text '<-- subject in cell 1 column right of found 1         .body = addrrng.offset(, 2).text '<-- subject in cell 2 column right of found 1         .attachments.add activeworkbook.fullname         'you can add other files         '.attachments.add ("c:\test.txt")         .send   'or use .display     end end sub 

• add following functions in module

  function getcountryaddressrange(ws worksheet, name string) range     dim f range     ws         set f = .range("a2", .cells(.rows.count, 1).end(xlup)).find(what:=name, lookin:=xlvalues, lookat:=xlwhole)     end     if not f nothing set getcountryaddressrange = f.offset(, 1) end function   function getoutlook() object     set getoutlook = getobject(, "outlook.application")     if getoutlook nothing set getoutlook = createobject("outlook.application") end function