Create Email from Excel by Row with Attachments Based on Recipients Matching in Each Row

[learningVBA321]

Hello, not sure how to best title this, but I have a sheet from which I loop through each row and create an email for each row. Attachments are based on the Division name. Currently, it creates an email for every row, so if one person under Name has, say 8 divisions, they will receive 8 emails, each with a different attachment. This is annoying people, so I want to have it now loop (maybe nested?) and if if finds the same Name, then create one email for that Name, with all their Divisions attached. To make it easier, I have set the list so that any dupe Names are all grouped together. In this example, I would want it to create one email to the Name Sample Sample1, with attachments for Widgets and Doorknobs. Then for the rest, they would each get their usual one email. I have tried for hours to get this to work, but simply do not have enough VBA knowledge to make this work. I can do it in Excel itself with formulas, basically saying that if A2=A3, then do this. But I need help to get this to happen in VBA. Please see the image and the code I have working currently.
Thanks!
Apparently I cannot add a picture unless it is a URL? So here is how it looks:
A B C
Name Email Division
Sample1 sample1@org.com Widgets
Sample1 sample1@org.com Doorknobs
Sample2 sample2@org.com Brooms
Sample3 sample3@org.com Mops

Here is the code:

Sub DivisionRpt()
'
'
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim strdir As String
    Dim strFilename As String
    Dim sigString As String
    Dim strBody As String
    Dim strName As String
    Dim strName1 As String
    Dim strDept As String
    Dim strName2 As String
   
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    
    sigString = Environ("appdata") & _
                "\Microsoft\Signatures\Division.htm"
                
        If Dir(sigString) <> "" Then
         signature = GetBoiler(sigString)
         Else
         signature = ""
        End If
        
  
    strdir = "z:\"
        
    strBody = "[FONT=calibri]Please review the attached report for your division.

"

    For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
               
        If cell.Value Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "C").Value) = "yes" Then
            Set OutMail = OutApp.CreateItem(0)
                        
                                   
        With OutMail
            strName = Cells(cell.Row, "a").Value
            strName1 = Cells(cell.Row, "d").Value
            strName2 = Left(strName, InStr(strName & " ", " ") - 1)
            strFilename = Dir("z:\" & strName1 & "*")
   
                .To = cell.Value
                .Subject = "Monthly Budget Deficit Report for " & strName1
                .HTMLBody = "[FONT=calibri]" & "Dear " & strName2 & ",

" & signature
                .Attachments.Add strdir & strFilename
                .Display  'Or use Send
        End With
          
            Set OutMail = Nothing
        End If
    Next cell

End Sub
[/FONT][/FONT]

 

[Johnny C]

I think you're nearly there. All you need to do is test if the name is the same as the previous one and use IF statements to create a new email if not. You can add more attachments as you go along if there are multiples.
The only awkward thing is you only process the email (display/Send/reset to nothing) at the start if it's not the first time it's run because you found a new name, so you process for the old one. Then at the end process the final one outside the loop because you know there are no more names.

Something like this, I haven't tested it but you hopefully see the logic.

    strPriorName = ""
    boolNewName = False
    boolFirstTime = True
    For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value <> strPriorName then 
             boolNewName = True
             if boolFirstTime = True Then
                 boolFirstTime = False
             Else
                 OutMail.Display  'Or use Send
                 Set OutMail = Nothing
             End If        
        End If
        If cell.Value Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "C").Value) = "yes" And_
           boolNewName = True Then
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
               strName = Cells(cell.Row, "a").Value
               strName1 = Cells(cell.Row, "d").Value
               strName2 = Left(strName, InStr(strName & " ", " ") - 1)
                .To = cell.Value
                .Subject = "Monthly Budget Deficit Report for " & strName1
                .HTMLBody = "" & "Dear " & strName2 & "," & signature
             End With
          End If                 
       Else
         If cell.Value Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "C").Value) = "yes" Then 
               strFilename = Dir("z:\" & strName1 & "*")
               OutMail.Attachments.Add strdir & strFilename
               OutMail.Subject =  OutMail.Subject & ", " & strName1
               strPriorName = cell.Value
           END If
       End If
    Next cell
    OutMail.Display  'Or use Send
    Set OutMail = Nothing

End Sub

HTH

 

[learningVBA321]

Thank you very much, but I could not get that to work. See what I did with it here, but it does not like the OutMail.Attachments or the Outmail. Display lines, erroring out with 'Object variable or With block variable not set'. Here is how I mixed your code in.

Sub test()
Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim strdir As String
    Dim strFilename As String
    Dim sigString As String
    Dim strBody As String
    Dim strName As String
    Dim strName1 As String
    Dim strDept As String
    Dim strName2 As String
    Dim strPriorName As String
   
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    
    sigString = Environ("appdata") & _
                "\Microsoft\Signatures\Division.htm"
                
        If Dir(sigString) <> "" Then
         signature = GetBoiler(sigString)
         Else
         signature = ""
        End If
        
        strdir = "z:\"
    
        
    strBody = "Please review the attached report for your division."

            strPriorName = ""
            boolNewName = False
            boolFirstTime = True
            For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
                If cell.Value <> strPriorName Then
                     boolNewName = True
                     If boolFirstTime = True Then
                         boolFirstTime = False
                     Else
                         OutMail.Display
                         Set OutMail = Nothing
                     End If
                End If
                If cell.Value Like "?*@?*.?*" And _
                   LCase(Cells(cell.Row, "C").Value) = "yes" And _
                   boolNewName = True Then
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                       strName = Cells(cell.Row, "a").Value
                       strName1 = Cells(cell.Row, "d").Value
                       strName2 = Left(strName, InStr(strName & " ", " ") - 1)
                       strFilename = Dir("z:\" & strName1 & "*")
                        .To = cell.Value
                        .Subject = "Monthly Budget Deficit Report for " & strName1
                        .HTMLBody = "" & "Dear " & strName2 & "," & signature
                        End With
                  End If
                  strFilename = Dir("z:\" & strName1 & "*")
                  OutMail.Attachments.Add strdir & strFilename
                               
            Next cell
            OutMail.Display  'Or use Send
            Set OutMail = Nothing
            

        End Sub