将基于工作簿名称的工作簿发送到不同的地址

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

在closures工作簿之前，它将新创build的工作簿发送到我的电子邮件地址。

如果工作簿被命名为“比利时”，请将电子邮件发送至[e-mail]，如果工作簿命名为“Bulagria”，则发送电子邮件至[e-mail]等等。 不同的国家通过电子邮件发送到不同的地址。

我的电子邮件代码在这里

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 = "[e-mail]" .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 = "[e-mail]" .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 

原始图片

国家图表

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

   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”语句并将返回值作为parameter passing给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 

当然，将信息存储在更容易修改的地方也是有意义的，比如主文件/插件中的Countries-Sheet。

 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