macros将多个文件发送到多个地址

请帮忙！！ 我需要build议或信息来帮助我完成这个耗时的任务。

每个月我都必须从内部数据库下载30个文件，并将它们保存在那个月的文件path中。 例如六月份文件path中的六月份文件。 然后，我必须将这些发送给30个不同的客户，他们与通用电子邮件相关。

例如AA客户工作簿到AA电子邮件地址。 所有客户信息和代码都保存在另一个工作簿中。

我想通过一个macros来做到这一点，但只具备在每个电子表格上安装macros的技能，然后必须input工作簿并单独运行（仍然很耗时）。 我希望有人能够指向我能够运行一个macros的方向，将一个文件夹中的所有文件发送给相关客户，或者将我指向类似的东西，这可以帮助我开始。

谢谢

码：

Sub Mail_Workbook_1() Dim OutApp As Object Dim OutMail As Object Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) On Error Resume Next With OutMail .to = "[e-mail]" .CC = "" .Subject = "Monthly Japan Order" .Body = "Good Morning,Please find this month's JPN order sheet attached." .Attachments.Add ActiveWorkbook.FullName .Send End With On Error GoTo 0 Set OutMail = Nothing Set OutApp = Nothing End Sub 

Answer 1

最好是创build一个Master.xlsm文件来处理电子邮件。
它应该包含两个工作表，[设置]和[电子邮件列表]。

工作表[设置]：

 +--------------------------------------------------------------------------------------+ ¦ ¦ A ¦ B ¦ ¦---+----------------+-----------------------------------------------------------------¦ ¦ 1 ¦ Folder Path ¦ C:\Report\2016\June ¦ ¦---+----------------+-----------------------------------------------------------------¦ ¦ 2 ¦ File Extension ¦ xls ¦ ¦---+----------------+-----------------------------------------------------------------¦ ¦ 3 ¦ Subject ¦ Monthly Japan Order ¦ ¦---+----------------+-----------------------------------------------------------------¦ ¦ 4 ¦ Body ¦ Good Morning,Please find this month's JPN order sheet attached. ¦ +--------------------------------------------------------------------------------------+ 

工作表[电子邮件列表]：列A应该没有空白条目

 +----------------------------------------------+ ¦ ¦ A ¦ B ¦ ¦---+-------------------------+----------------¦ ¦ 1 ¦ To ¦ File Base Name ¦ ¦---+-------------------------+----------------¦ ¦ 2 ¦ [e-mail] ¦ bj ¦ ¦---+-------------------------+----------------¦ ¦ 3 ¦ [e-mail] ¦ aa ¦ ¦---+-------------------------+----------------¦ ¦ 4 ¦ [e-mail] ¦ ab ¦ ¦---+-------------------------+----------------¦ ¦ 5 ¦ [e-mail] ¦ ac ¦ +----------------------------------------------+ 

将此代码粘贴到公共模块中。 当你运行ProcessFiles（）它应该遍历你的邮件列表并发送你的电子邮件。

 Option Explicit Public Sub ProcessFiles() 'Setup Outlook Dim OutApp As Object Set OutApp = CreateObject("Outlook.Application") Dim rowCount As Integer, i As Integer Dim fileName As String, emailTo As String With Worksheets("Email List") rowCount = Application.WorksheetFunction.CountA(.Columns(1)) For i = 2 To rowCount emailTo = .Cells(i, 1) fileName = getFileName(.Cells(i, 2)) If Len(Dir(fileName)) Then SendMail emailTo, fileName, OutApp Next End With Set OutApp = Nothing End Sub Public Function getFileName(fileBaseName As String) Dim folderPath As String, fileExtension As String, fileName As String folderPath = Range("Settings!B1") fileExtension = Range("Settings!B2") If Left(fileExtension, 1) <> "." Then fileExtension = "." & fileExtension If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\" getFileName = folderPath & fileBaseName & fileExtension End Function Public Sub SendMail(emailTo As String, fileName As String, OutApp As Object) Dim OutMail As Object Set OutMail = OutApp.CreateItem(0) On Error Resume Next With OutMail .to = emailTo .CC = "" .subject = Range("Settings!B3") .body = Range("Settings!B4") .Attachments.Add fileName .Send End With On Error GoTo 0 Set OutMail = Nothing End Sub 

Answer 2

（更好的信息给出）…听起来像你需要从VBAmacros录像机代码。 您需要掌握使用variables来引用工作簿和工作表，而不是依赖来自macroslogging器的ActiveWorkbook和ActiveSheet。

尝试这个

 Option Explicit Private Sub Test() '* Specify wb instead of ActiveWorkbook '* Here's how to open a file Dim wb As Excel.Workbook Set wb = Workbooks.Open("c:\temp\bbc.txt") '* Specify sheet instead of activesheet Dim ws As Excel.Worksheet Set ws = wb.Worksheets(1) '* in your macro code replace activeworkbook with wb '* in your macro code replace activesheet with ws End Sub '* Tools ->References -> Microsoft Sscripting Runtime Private Sub ToCycleThroughFiles() Dim fso As Scripting.FileSystemObject Set fso = New Scripting.FileSystemObject Dim sTodaysYear As String sTodaysYear = Format(Now(), "yyyy") Dim sTodaysMonth As String sTodaysMonth = Format(Now(), "mmmm") Dim sFolder As String sFolder = "H:\Departments\01 GPPD Department - New\VV Customers\" & sTodaysYear & "\" & sTodaysMonth Dim fld As Scripting.Folder Set fld = fso.GetFolder(sFolder) Dim filLoop As Scripting.File For Each filLoop In fld.Files If InStr(1, filLoop.Name, ".xls", vbTextCompare) > 0 Then '* only interested in excel files, xls, xlsm etc. Dim vSplitFileName As Variant vSplitFileName = VBA.Split(filLoop.Name, ".") If Len(vSplitFileName(0)) = 2 Then '* two character named workbook, eg aa.xls, ab.xls, ah.xls, de.xls Call SubRoutine(filLoop.Path) End If End If Next filLoop End Sub Private Sub SubRoutine(ByVal sWorkbookFullFileName As String) '* Do your stuff for each workbook here Dim wb As Excel.Workbook Set wb = Workbooks.Open(sWorkbookFullFileName) '.... wb.Close End Sub