基于工作簿名称到不同地址的电子邮件工作簿
我有一个代码,打开一个对话框,允许用户选择一个Excel工作表,过滤国家列(11),将该国家复制并粘贴到一个新的工作簿中,在该国之后的新工作簿,重复下一个国家的行动,保存并关闭每个工作簿。基于工作簿名称到不同地址的电子邮件工作簿
目前在关闭工作簿之前,它会将新创建的工作簿发送到我的电子邮件地址。
我想如果工作簿被命名为“比利时”电子邮件[email protected],如果工作簿命名为“Bulagria”电子邮件给[email protected]等。不同的国家通过电子邮件发送到不同的地址。
我的电子邮件代码是在这里
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
主要代码身体
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
产品图国表
012的图片
可以尝试以下步骤
- 在
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
在
-
,添加
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
Public Sub Filter(my_Workbook As Workbook)
再次感谢您的帮助。一如既往,非常感谢。不幸的是我得到'运行时错误9下标超出范围'在这一行上'设置addrRng = GetCountryAddressRange(.Parent.Parent.Worksheets(“国家”),rCountry.Value2)'
我假设在您打开的工作簿中存在“国家/地区”工作表 – user3598756
是的我的工作簿中有一个名为“国家/地区”的工作表。 –
最简单的方法是使用“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
感谢您的帮助。非常感谢。第一段代码。我从未在任何代码中插入函数。我在哪里将它放在我现有的代码中 –
我已添加图片以便更好地理解。再次感谢您的帮助 –
只需将它放置在Sub下面,它基本上与Sub的结构相同,只不过它返回一个值(通过为函数名称分配一个值)。 – matthias
你在哪里存储国家邮件信件?在一些细胞中? – user3598756
@ user3598756:嗨啊好吧,所以我需要将电子邮件地址存储在另一个工作表上的某个地方,这是正确的吗? –
我添加了更好的理解照片。再次感谢您的帮助 –