Macro to send multiple files to multiple address

Question

Please help!! I need advice or info to help me complete this time consuming task.

Every month I have to download 30 files from an internal database, saving them in that months file path. e.g. June files in June's file path. I then have to send these to the 30 different customers to who they relate on a generic email.

e.g AA customers workbook to AA email address. All customer information and codes are saved on another workbook.

I want to do this by a macro but only have the skills to install a macro on each spread sheet and then have to enter the workbook and run them individually (still time consuming). I was hoping somebody would be able to point me in the direction of being able to run one macro that send all the files in one folder to the relevant customer or would point me to something similar which can help me get started.

Thanks

Code:

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

It would be better to create a Master.xlsm file to process the emails.
It should contain two worksheets, [Settings] and [Email List].

Worksheet [Settings]:

+--------------------------------------------------------------------------------------+
¦   ¦ 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. ¦
+--------------------------------------------------------------------------------------+

Worksheet [Email List]: Column A should have no blank entries

+----------------------------------------------+
¦   ¦ 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             ¦
+----------------------------------------------+

Paste this code in a public module. When your run ProcessFiles() it should iterate through your email list and send out your emails.

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

(Better information given) ... sounds like you need to step up from VBA Macro Recorder code. You'll need to master referencing workbooks and worksheets with variables instead of relying upon ActiveWorkbook and ActiveSheet which come from macro recorder.

Try this

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