篩選器和電子郵件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 = "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）區，並在膠原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