Фильтр и файл электронной почты 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

Я предполагаю, что вы хотите сделать это программно с помощью 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

Jon

Я предполагаю следующее.

1) Регионы в Col AH

2) Контакты в Col 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

Answer 3

Если у вас возникли проблемы с вышеуказанным, мой почтовый макрос отличается;используется в 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