Userforms in Excel to generate custom Email Templates for outlook

Question

I have a company and vendor contact list that I would like to have a userform the you select which type of email you want to create with sub sets:

such as RFP, PO Request.

For RFP there would be different email templates based on which service/material you are selecting and then each of those would have multiple different vendors that would each need there own separate email, just with the same body and subject line.

I would also like the subject line to be variable input in the form.

-Ideally the user form would have either a list or drop down that say RFP or PO Request

-After that selection is made If its RFP I would like it to have an option to choose which services/materials

this would pick what the body of the email would be

-the user would input the Project name/ subject line

-then select the vendors you want the rfp to go to and have it generate emails for all of those people would generate after a button is hit.

the service and material and vendors would all be selectable from the workbook.

Also, the vendors have multiple emails for each vendor but each vendor only needs 1 email template but all email address for that company need to be on the email

I would also like all emails to have a CC'd person, will be the same person every time

nikolinode · Answer

UserForm Code (VBA)Paste into the code for your UserForm:Private Sub UserForm_Initialize()
    cmbEmailType.AddItem "RFP"
    cmbEmailType.AddItem "PO Request"
End Sub

Private Sub cmbEmailType_Change()
    cmbServiceMaterial.Clear
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("ServicesMaterials")
    
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    Dim i As Long
    For i = 2 To lastRow
        If ws.Cells(i, 1).Value = cmbEmailType.Value Then
            cmbServiceMaterial.AddItem ws.Cells(i, 2).Value
        End If
    Next i
End Sub

Private Sub cmbServiceMaterial_Change()
    lstVendors.Clear
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Vendors")
    
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    Dim i As Long
    For i = 2 To lastRow
        If ws.Cells(i, 2).Value = cmbServiceMaterial.Value Then
            If Not dict.exists(ws.Cells(i, 1).Value) Then
                dict.Add ws.Cells(i, 1).Value, True
                lstVendors.AddItem ws.Cells(i, 1).Value
            End If
        End If
    Next i
End Sub

Private Sub btnGenerateEmails_Click()
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Set OutlookApp = CreateObject("Outlook.Application")
    
    Dim wsVendors As Worksheet, wsServices As Worksheet, wsSettings As Worksheet
    Set wsVendors = ThisWorkbook.Sheets("Vendors")
    Set wsServices = ThisWorkbook.Sheets("ServicesMaterials")
    Set wsSettings = ThisWorkbook.Sheets("Settings")
    
    Dim templateBody As String
    Dim i As Long
    For i = 2 To wsServices.Cells(wsServices.Rows.Count, 1).End(xlUp).Row
        If wsServices.Cells(i, 1).Value = cmbEmailType.Value And wsServices.Cells(i, 2).Value = cmbServiceMaterial.Value Then
            templateBody = wsServices.Cells(i, 3).Value
            Exit For
        End If
    Next i
    
    Dim ccEmail As String
    ccEmail = wsSettings.Range("B1").Value ' Assuming CC is in B1
    
    Dim vendorRow As Long
    For i = 0 To lstVendors.ListCount - 1
        If lstVendors.Selected(i) Then
            Dim vendorName As String
            vendorName = lstVendors.List(i)
            
            Dim emailList As String
            emailList = ""
            
            For vendorRow = 2 To wsVendors.Cells(wsVendors.Rows.Count, 1).End(xlUp).Row
                If wsVendors.Cells(vendorRow, 1).Value = vendorName And _
                   wsVendors.Cells(vendorRow, 2).Value = cmbServiceMaterial.Value Then
                   
                   emailList = emailList &amp; ";" &amp; wsVendors.Cells(vendorRow, 4).Value
                End If
            Next vendorRow
            
            Set OutlookMail = OutlookApp.CreateItem(0)
            With OutlookMail
                .To = Mid(emailList, 2)
                .CC = ccEmail
                .Subject = txtProjectName.Value
                .Body = templateBody
                .Display ' or use .Send to auto-send
            End With
        End If
    Next i
End Sub
'VBA Code is untested, please backup you file first.&nbsp;My answers are voluntary and without guarantee!&nbsp;Hope this will help you.

Forum Discussion

Userforms in Excel to generate custom Email Templates for outlook

1 Reply

Resources