Generate Email

[gheyman]

I have the code below that is meant to create one email and populate the that email with data from the excel workbook.

Can this code be modified so that it looks down a column in a table and if row says "SharePoint" it creates a new email each time using the data from the applicable row?

The data/table is on a tab named SharePoint. The table Name is SharePointTable The table start in B31 (headers)
Need it to look down column B for "SharePoint"

The applicable data for the emails is still coming from columns D and C of each row in the table


Thank you very much for the time and help. Greatly appreciated.

code that needs to be modified:

Option Explicit

Sub Mail_workbook_Outlook()

    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 = "gregory.heyman@DRS.com"
        .CC = ""
        .BCC = ""
        .Subject = "#" & Sheets("Step 7").Range("D31").Text & "#" & "   " & Sheets("Step 7").Range("C31").Text
        .Body = "This email will generate a new folder in Sharepoint and save this workbook there." & vbNewLine & vbNewLine & "You may add additional attachments, that you want saved to this Quote folder. " & vbNewLine & vbNewLine & "The         Folder will be named after the Source ID (The email Subject)" & vbNewLine & vbNewLine & "  " & vbNewLine & vbNewLine & "PLEASE DO NOT CHANGE THE SUBJECT NAME"
        .Attachments.Add (Application.ActiveWorkbook.FullName)
       
        '.Send
        .display
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

 

[JEC]

I think you mean something like this

Sub jec()
 Dim it
 For Each it In Sheets("SharePoint").ListObjects("SharePointTable").DataBodyRange.Columns(2).Cells
   If it.Value = "SharePoint" Then
      With CreateObject("outlook.application").createitem(0)
        .to = "test@gmail.com"
        .Subject = ""
        .body = it.Offset(, 2) & "---" & it.Offset(, 1)
        .attachments.Add ThisWorkbook.FullName
        .display  '.send
     End With
   End If
 Next
End Sub

 

[gheyman]

Thank you!

Here is what I ended up with. It works but seems very slow.

Sub Create_Email()

Dim SPCount


'If SPCount < 3 Then Exit Sub

 For Each SPCount In Sheets("SharePoint").ListObjects("SharePointTable").DataBodyRange.Columns(1).Cells
  
   If SPCount.Value = "SharePoint" Then
      With CreateObject("outlook.application").createitem(0)
        .to = "gregory.heyman@DRS.com"
        .CC = ""
        .BCC = ""
        .Subject = "#" & SPCount.Offset(, 2) & "#" & "  " & SPCount.Offset(, 1)
        .body = "SharePoint Folder Name: " & SPCount.Offset(, 2) & vbNewLine & vbNewLine & "Vendor: " & SPCount.Offset(, 1) & vbNewLine & vbNewLine & "This email will generate a new folder in SharePoint and save this workbook there." & vbNewLine & vbNewLine & "You may add additional attachments, that you want saved to this Quote folder. " & vbNewLine & vbNewLine & "The Folder will be named after the Cost Source ID (The email Subject)" & vbNewLine & vbNewLine & "  " & vbNewLine & vbNewLine & "PLEASE DO NOT CHANGE THE EMAIL SUBJECT"
        .attachments.Add ThisWorkbook.FullName
        .display
     End With
   End If
   
 Next


End Sub

 

[JEC]

Yes it is slow because it creates individual emails for every row.

You are welcome!