筛选器和电子邮件Excel文件（VBA）

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

我假设你希望它programmaticaly用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) 

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 = "[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 

Answer 3

乔恩

我假设如下。

1）区，并在胶原AH

2）联系是在山口AI

3）UniqueItems（）在代码中删除重复？

请尝试下面的代码。我已经评论了该代码，请通过它们并进行相关更改。尤其是保存文件的部分。我已经使用Outlook的后期绑定。

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

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