フィルタファイルと電子メールExcelファイル（VBA）

Question

私は分割して特定の人に特定のアカウントを送信する必要がある関連情報を持っています。これは約50回行わなければならない。私はすでにフィルタリングし、新しいファイルにデータをコピーして保存するプログラムの設定をしています。連絡先のリストに基づいてこのファイルを電子メールで送信するように設定する方法はありますか？

各アカウントは地域でカバーされているため、地域と連絡先のメールが記載されたリストがあります。地域によって分割されたマクロでは、これらの地域の配列を持っているので、連絡先リストから何らかの検索が可能ですか？

コード：私はあなたがVBを使用してprogrammaticalyそれをしたいと仮定しています

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

あなたは上記で問題がある場合、あなたは

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）地域は

2）コンタクトは、あなたのコード内でコルAI

3）UniqueItems（）内にあるコルAHであり、重複を削除しますか？

次のコードを試してください。私はコードをコメントしていますので、それらを見て、関連する変更を加えてください。特に、ファイルを保存する部分。私は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