基于工作簿名称到不同地址的电子邮件工作簿

Question

我有一个代码，打开一个对话框，允许用户选择一个Excel工作表，过滤国家列（11），将该国家复制并粘贴到一个新的工作簿中，在该国之后的新工作簿，重复下一个国家的行动，保存并关闭每个工作簿。

目前在关闭工作簿之前，它会将新创建的工作簿发送到我的电子邮件地址。

我想如果工作簿被命名为“比利时”电子邮件Jane.Doe@email.com，如果工作簿命名为“Bulagria”电子邮件给John.Doe@Email.com等。不同的国家通过电子邮件发送到不同的地址。

我的电子邮件代码是在这里

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 

主要代码身体

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 

原始

产品图国表

012的图片

Answer 1

可以尝试以下步骤

• 在Public Sub Filter(my_Workbook As Workbook)

  ，加

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

  声明之间

• 在Public Sub Filter(my_Workbook As Workbook)添加

  Set outApp = GetOutlook 
  

  之前

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

• 在Public Sub Filter(my_Workbook As Workbook)

  ，加

    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 
  

  之间

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

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

在 Public Sub Filter(my_Workbook As Workbook)

• ，添加

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

  之前End Sub

• 修改Mail_workbook_Outlook_1如下

  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 
  

• 任何模块中添加以下功能

  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

最简单的方法是使用“select case”语句并将返回值作为参数传递给Mail_workbook_Outlook_1。

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 

当然，这将是有意义的地方存储信息的地方是比较容易也许要修改，在你的主文件/插件一个国家的片材。

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