Question

请帮忙!!我需要建议或信息来帮助我完成这项耗时的任务。

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

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

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

由于

代码：

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 = "bradley.johns@xxxx.net"
        .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

最好创建一个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 ¦ bradley.johns@xxxx.net  ¦ bj             ¦
¦---+-------------------------+----------------¦
¦ 3 ¦ bradley.adrian@xxxx.net ¦ aa             ¦
¦---+-------------------------+----------------¦
¦ 4 ¦ frank.johns@xxxx.net    ¦ ab             ¦
¦---+-------------------------+----------------¦
¦ 5 ¦ trump.donals@xxxx.net   ¦ 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

（提供更好的信息）......听起来你需要从VBA宏记录器代码升级。您需要掌握使用变量引用工作簿和工作表，而不是依赖来自宏录制器的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, e.g. 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

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

2 个答案: