Question

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

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

代码：

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

Answer 1

我假设您希望使用VB以编程方式执行此操作，您可以执行类似

的操作

 Dim msg As System.Web.Mail.MailMessage = New System.Web.Mail.MailMessage() 
 msg.From = "noone@nobody.com" 
 msg.To = "someone@somewhere.com" 
 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)

Answer 2

如果您遇到上述问题，我的邮件宏不同;这与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 = "anyone@anywhere.com"
        .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

Answer 3

乔恩

我假设以下内容。

1）区域在Col AH

2）联系人在Col AI

3）你的代码中的UniqueItems（）会删除重复项吗？

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

注意： 我总是在发布之前测试我的代码，但在当前情况下，如果发现任何错误，我不能告诉我。

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

过滤和发送电子邮件Excel文件（VBA）

3 个答案: