过滤器和电子邮件 Excel 文件 (VBA)

Filter and Email Excel File (VBA)

提问by postelrich

I have a list of accounts and relevant information that I have to split up and send specific accounts to certain people. This has to be done about 50 times. I already have a program setup that will filter, copy the data to a new file, and save. Is there a way to set it up to then email this file based on a list of contacts?

我有一个帐户和相关信息的列表，我必须将这些信息拆分并将特定帐户发送给某些人。这必须执行大约 50 次。我已经有一个程序设置，可以过滤，将数据复制到一个新文件，然后保存。有没有办法设置它然后根据联系人列表通过电子邮件发送此文件？

Each account is covered by a region, so I have a list which has the region and the contact's email. In the macro that splits by the regions, it has an array of these regions so is some kind of lookup possible from the list of contacts?

每个帐户都由一个区域覆盖，因此我有一个列表，其中包含该区域和联系人的电子邮件。在按区域拆分的宏中，它具有这些区域的数组，因此可以从联系人列表中进行某种查找吗？

Code:

代码：

Sub SplitFile()

Dim rTemp As Range
Dim regions() As String

Set rTemp = ThisWorkbook.Sheets("Combined").Range("AH2:AH1455")
regions = UniqueItems(rTemp, False)
For N = 1 To UBound(regions)
    Set wb = Workbooks.Add

    ThisWorkbook.Sheets("DVal").Copy _
       after:=ActiveWorkbook.Sheets("Sheet1")

    With ThisWorkbook.Sheets("Combined")
        .AutoFilterMode = False
'        .AutoFilter
        .Range("A1:BP1455").AutoFilter Field:=34, Criteria1:=regions(N)
              Application.DisplayAlerts = False
        .Range("A1:BP1455").Copy wb.Sheets("Sheet1").Range("A1")
              Application.DisplayAlerts = True
        For c = 1 To 68
            wb.Sheets("Sheet1").Range("A1:BP2694").Columns(c).ColumnWidth = .Columns(c).ColumnWidth
        Next c
    End With

    With wb
        .Sheets("Sheet1").Activate
        .SaveAs Filename:="H:\" & regions(N) & " 14-12-11"
        .Close True
    End With

    Set wb = Nothing
Next N

End Sub

回答by Emmanuel N

I am assuming you want to do it programmaticaly using VB, you can do something like

我假设您想使用 VB 以编程方式执行此操作，您可以执行以下操作

 Dim msg As System.Web.Mail.MailMessage = New System.Web.Mail.MailMessage() 
 msg.From = "[email protected]" 
 msg.To = "[email protected]" 
 msg.Subject = "Email with Attachment Demo" 
 msg.Body = "This is the main body of the email" 
 Dim attch As MailAttachment = New MailAttachment("C:\attachment.xls") 
 msg.Attachments.Add(attch) 
 SmtpMail.Send(msg)

回答by Jon

If you're having trouble with the above, my mail macro is different; this is used with excel 2007:

如果你有上面的问题，我的邮件宏是不同的；这与 excel 2007 一起使用：

Sub Mail()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    strbody = "To Whom It May Concern:" & vbNewLine & vbNewLine & _
              "This is a test!" & vbNewLine & _
              "This is line 2" & vbNewLine & _
              "This is line 3" & vbNewLine & _
              "This is line 4"

    On Error Resume Next
    With OutMail
        .to = "[email protected]"
        .cc = ""
        .BCC = ""
        .Subject = "This is only a test"
        .Body = strbody
        'You can add an attachment 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

回答by Siddharth Rout

Jon

乔恩

I am assuming the following.

我假设如下。

1) Regions are in Col AH

1) 区域位于 Col AH

2) Contacts are in Col AI

2) 联系人在 Col AI

3) UniqueItems() in your code removes duplicates?

3) 您的代码中的 UniqueItems() 会删除重复项吗？

Please try the below code. I have commented the code so please go through them and make relevant changes. Especially to the part where you save the File. I have used Late Binding with Outlook.

请尝试以下代码。我已经对代码进行了评论，因此请仔细阅读并进行相关更改。特别是保存文件的部分。我在 Outlook 中使用了后期绑定。

NOTE:I always test my code before posting but in the current scenario I cannot so do let me know if you find any errors.

注意：我总是在发布之前测试我的代码，但在当前情况下，如果您发现任何错误，我不能这样做让我知道。

Option Explicit

Sub SplitFile()
    '~~> Excel variables
    Dim wb As Workbook, wbtemp As Workbook
    Dim rTemp As Range, rng As Range
    Dim regions() As String, FileExt As String, flName As String
    Dim N As Long, FileFrmt As Long

    '~~> OutLook Variables
    Dim OutApp As Object, OutMail As Object
    Dim strbody As String, strTo As String

    On Error GoTo Whoa

    Application.ScreenUpdating = False

    Set wb = ActiveWorkbook

    '~~> Just Regions
    Set rTemp = wb.Sheets("Combined").Range("AH2:AH1455")
    '~~> Regions and Email address. We wil require this later
    '~~> Tofind email addresses
    Set rng = wb.Sheets("Combined").Range("AH2:AI1455")

    regions = UniqueItems(rTemp, False)

    '~~> Create an instance of outlook
    Set OutApp = CreateObject("Outlook.Application")

    For N = 1 To UBound(regions)
        Set wb1 = Workbooks.Add

        wb.Sheets("DVal").Copy after:=wb1.Sheets(1)

        With wb.Sheets("Combined")
            .AutoFilterMode = False
            With .Range("A1:BP1455")
                .AutoFilter Field:=34, Criteria1:=regions(N)
                '~~> I think you want to copy the filtered data???
                .Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy _
                wb1.Sheets("Sheet1").Range("A1")

                For c = 1 To 68
                    wb1.Sheets("Sheet1").Range("A1:BP2694").Columns(c).ColumnWidth = _
                    wb.Columns(c).ColumnWidth
                Next c
            End With
        End With

        '~~> Set the relevant Fileformat for Save As
        ' 51 = xlOpenXMLWorkbook (without macro's in 2007-2010, xlsx)
        ' 52 = xlOpenXMLWorkbookMacroEnabled (with or without macro's in 2007-2010, xlsm)
        ' 50 = xlExcel12 (Excel Binary Workbook in 2007-2010 with or without macro's, xlsb)
        ' 56 = xlExcel8 (97-2003 format in Excel 2007-2010, xls)

        FileFrmt = 52

        Select Case FileFrmt
        Case 50: FileExt = ".xlsb"
        Case 51: FileExt = ".xlsx"
        Case 52: FileExt = ".xlsm"
        Case 56: FileExt = ".xls"
        End Select

        '~~> Contruct the file name.
        flName = "H:\" & regions(N) & " 14-12-11" & FileExt

        '~~> Do the save as
        wb1.SaveAs Filename:=flName, FileFormat:=FileFrmt
        wb1.Close SaveChanges:=False

        '~~> Find the email address
        strTo = Application.WorksheetFunction.VLookup(regions(N), rng, 2, 0)

        '~~> Create new email item
        Set OutMail = OutApp.CreateItem(0)

        '~~> Create the body of the email here. Change as applicable
        strbody = "Dear Mr xyz..."

        With OutMail
            .To = strTo
            .Subject = regions(N) & " 14-12-11" '<~~ Change subject here
            .Body = strbody
            .Attachments.Add flName
            '~~> Uncomment the below if you just want to display the email
            '~~> and comment .Send
            '.Display
            .Send
        End With
    Next N

LetContinue:
    Application.ScreenUpdating = True

    '~~> CleanUp
    On Error Resume Next
    Set wb = Nothing
    Set wb1 = Nothing
    Set OutMail = Nothing
    OutApp.Quit
    Set OutApp = Nothing
    On Error GoTo 0
Whoa:
    MsgBox Err.Description
    Resume LetContinue
End Sub