Question

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

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

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

我的电子邮件CODE就在这里

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

原始图片

国家表的图片

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

最简单的方法是使用＆＃34;选择案例＆＃34;声明并将返回值作为参数传递给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

当然，将信息存储在易于修改的地方是有意义的，也可以在master-file / addin中存储States-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

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

2 个答案: