VBA Copy Data from Sheet to Email depending on Assignee

[2000km12]

Hello! I currently have a Macro that creates an email for each row of data, then copies and pastes that row into the email. Each row is assigned to an individual (receiver of the email),, but sometimes, the same individual is assigned to multiple rows. I wanted to see if I could change up the code so that, if the same person is assigned multiple rows, that the whole group of rows will be copied to the email. This would minimize the number of emails I'm sending out to each person every morning.

Here's a snippet of the code I have right now. There is a bunch more code involved, this is just the code relevant to my question.
'Create the variables for the loop
Dim LastRw As Long, FirstRw As Long
Dim Rw As Long
'Create variables needed for RangeToHTML
Dim rng As Range
Dim rngHeader As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Selection.SpecialCells(xlCellTypeVisible)
With ActiveSheet
'Define First and Last Rows
FirstRw = 2
LastRw = sht.UsedRange.Rows(.UsedRange.Rows.Count).Row

'Create loop to go through all rows
For Rw = LastRw To FirstRw Step -1

'If the due date is equal to today, run code:
If sht.Range("G" & Rw).Value = Date Then

'Set Variables for RangeToHTML Function:
Set rng1 = sht.Range("A" & Rw).SpecialCells(xlCellTypeVisible)
Set rng2 = sht.Range("B" & Rw).SpecialCells(xlCellTypeVisible)
Set rng3 = sht.Range("C" & Rw).SpecialCells(xlCellTypeVisible)
Set rng4 = sht.Range("D" & Rw).SpecialCells(xlCellTypeVisible)
Set rng5 = sht.Range("E" & Rw).SpecialCells(xlCellTypeVisible)
Set rng6 = sht.Range("F" & Rw).SpecialCells(xlCellTypeVisible)
Set rng7 = sht.Range("G" & Rw).SpecialCells(xlCellTypeVisible)
Set rng = Union(rng1, rng2, rng3, rng4, rng5, rng6, rng7)
Set rngHeader = sht.Range("A1:G1").SpecialCells(xlCellTypeVisible)


Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

'Create Signature
With OutMail
.Display
End With


'Create Email
With OutMail
.Subject = "Reminder - " & sht.Range("A" & Rw).Value & " Due Today"
'.Subject = "Reminder - CAR(s) Due Today"
.To = sht.Range("B" & Rw).Value
.CC = "Brianna Willson"

.HTMLBody = "Good Morning," & "<br>" & "<br>" & "This is a friendly reminder that you have a Corrective Action" & "<b>" _
& " due today." & "</b>" & " Please let me or Brianna Willson know if you require any additional support. " & "<br>" & "<br>" _
& "<u>" & "Please note, an extension cannot be requested as we are past the extension request due date. This action must be" & _
" completed today to avoid escalation." & "</u>" & "<br>" & "<br>" & RangetoHTML(rngHeader) & RangetoHTML(rng) & "<br>" & "<br>" _
& "Thank You," & "<br>" & "<br>" & .HTMLBody

.Display
End With
Set OutApp = Nothing
Set OutMail = Nothing

ElseIf sht.Range("G" & Rw).Value = Date + 2 Or ((Format(Now(), "DDD") = "Thu" Or Format(Now(), "DDD") = "Fri") And .Range("G" & Rw).Value = Date + 4) Then

'Set Variables for RangeToHTML Function:
Set rng1 = sht.Range("A" & Rw).SpecialCells(xlCellTypeVisible)
Set rng2 = sht.Range("B" & Rw).SpecialCells(xlCellTypeVisible)
Set rng3 = sht.Range("C" & Rw).SpecialCells(xlCellTypeVisible)
Set rng4 = sht.Range("D" & Rw).SpecialCells(xlCellTypeVisible)
Set rng5 = sht.Range("E" & Rw).SpecialCells(xlCellTypeVisible)
Set rng6 = sht.Range("F" & Rw).SpecialCells(xlCellTypeVisible)
Set rng7 = sht.Range("G" & Rw).SpecialCells(xlCellTypeVisible)
Set rng = Union(rng1, rng2, rng3, rng4, rng5, rng6, rng7)
Set rngHeader = sht.Range("A1:G1").SpecialCells(xlCellTypeVisible)

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Create Signature
With OutMail
.Display
End With


'Create Email
With OutMail
.Subject = "Reminder - " & sht.Range("A" & Rw).Value & " Upcoming Due Date"
'.Subject = "Reminder - CAR(s) Upcoming Due Dates"
.To = sht.Range("B" & Rw).Value
.CC = "Brianna Willson"

.HTMLBody = "Good Morning," & "<br>" & "<br>" & "This is a friendly reminder that you have a Corrective Action due in " & "<b>" _
& "two business days." & "</b>" & " Please let me or Brianna Willson know if you require any additional support or would like to" _
& " request an extension." & "<br>" & "<br>" & "<b>" & "<u>" & "<span style='background:yellow;mso-highlight:yellow'>" & _
"Please request an extension today or tomorrow; extensions cannot be requested the day the action is due." & _
"</span>" & "</b>" & "</u>" & "<br>" & "<br>" & "<br>" & RangetoHTML(rngHeader) & RangetoHTML(rng) & "<br>" & "<br>" & "Thank You," & _
"<br>" & "<br>" & .HTMLBody


.Display
End With
Set OutApp = Nothing
Set OutMail = Nothing
End If
Next Rw
End With

 

[sijpie]

Hi 2000km12, when you put code in a post, please use code brackets. Press the little VBA icon and then paste your code.

Hopefully this code works. Read the comments to understand what it does. I can't test it as I don't have outlook, nor your input data.

'this macro goes through the filtered list one row at a time, _
checking the due date foor each action. _
if the due date is Today the line is copied to the first table on a temporary sheet. _
When the date is soon, then the line is copied to a second table on the temp sheet. _
Then emails are created inserting each of the tables into the email.

'Create the variables for the loop
Dim LastRw As Long, FirstRw As Long, Rw As Long, lRot As Long, lRos As Long
Dim rngLine As Range, rngHeader As Range
Dim wsTemp As Worksheet, wsInput As Worksheet
'and for the output mail
Dim OutApp As Object, OutMail As Object
Dim bToday As Boolean, bSoon As Boolean



Set wsInput = ActiveSheet
Sheets.Add
Set wsTemp = ActiveSheet

On Error Resume Next '<<<<<< Do you need this line? Try commenting it out

With wsInput
'Define First and Last Rows
FirstRw = 2
LastRw = wsInput.UsedRange.Rows(.UsedRange.Rows.Count).Row

Set rngHeader = wsInput.Range("A1:G1").SpecialCells(xlCellTypeVisible)
'copy headers to the two output ranges on the temporary sheet
rngHeader.Copy wsTemp.Range("A1")
rngHeader.Copy wsTemp.Range("K1")
'next output line
lRot = 2: lRos = 2

'Create loop to go through all rows, build two tables in the temporary sheet _
table starting A1 is items to be closed Today _
table starting K1 is items to be closed Soon
For Rw = LastRw To FirstRw Step -1

'If the due date is equal to today, run code:
If wsInput.Range("G" & Rw).Value = Date Then

Set rngLine = wsInput.Range("A" & Rw & ":G" & Rw).SpecialCells(xlCellTypeVisible)
rngLine.Copy wsTemp.Cells(lRot, "A")
lRot = lRot + 1

ElseIf wsInput.Range("G" & Rw).Value = Date + 2 Or ((Format(Now(), "DDD") = "Thu" Or _
Format(Now(), "DDD") = "Fri") _
And .Range("G" & Rw).Value = Date + 4) Then

Set rngLine = wsInput.Range("A" & Rw & ":G" & Rw).SpecialCells(xlCellTypeVisible)
rngLine.Copy wsTemp.Cells(lRos, "K")
lRos = lRos + 1

End If
Next Rw

If wsTemp.Cells(1, "A").CurrentRegion.Rows.Count > 1 Then bToday = True
If wsTemp.Cells(1, "K").CurrentRegion.Rows.Count > 1 Then bSoon = True

If bSoon Or bToday Then
Set OutApp = CreateObject("Outlook.Application")

If bToday Then
Set OutMail = OutApp.CreateItem(0)
'Create Signature
With OutMail
.Display
End With



Set OutApp = CreateObject("Outlook.Application")

Set OutMail = OutApp.CreateItem(0)

'Create Signature
With OutMail
.Display
End With


'Create Email
With OutMail
.Subject = "Reminder - " & wsInput.Range("A" & Rw).Value & " Due Today"
'.Subject = "Reminder - CAR(s) Due Today"
.To = wsInput.Range("B" & Rw).Value
.CC = "Brianna Willson"

.HTMLBody = "Good Morning," & "<br>" & "<br>" & "This is a friendly reminder that you have a Corrective Action" & "<b>" _
& " due today." & "</b>" & " Please let me or Brianna Willson know if you require any additional support. " & "<br>" & "<br>" _
& "<u>" & "Please note, an extension cannot be requested as we are past the extension request due date. This action must be" & _
" completed today to avoid escalation." & "</u>" & "<br>" & "<br>" & RangetoHTML(wsTemp.Cells(1, "A").CurrentRegion) & "<br>" & "<br>" _
& "Thank You," & "<br>" & "<br>" & .HTMLBody

.Display
End With
End If

If bSoon Then
Set OutMail = CreateObject("Outlook.Application")

'Create Email
With OutMail
.Subject = "Reminder - " & wsInput.Range("A" & Rw).Value & " Upcoming Due Date"
'.Subject = "Reminder - CAR(s) Upcoming Due Dates"
.To = wsInput.Range("B" & Rw).Value
.CC = "Brianna Willson"

.HTMLBody = "Good Morning," & "<br>" & "<br>" & "This is a friendly reminder that you have a Corrective Action due in " & "<b>" _
& "two business days." & "</b>" & " Please let me or Brianna Willson know if you require any additional support or would like to" _
& " request an extension." & "<br>" & "<br>" & "<b>" & "<u>" & "<span style='background:yellow;mso-highlight:yellow'>" & _
"Please request an extension today or tomorrow; extensions cannot be requested the day the action is due." & _
"</span>" & "</b>" & "</u>" & "<br>" & "<br>" & "<br>" & RangetoHTML(rngHeader) & RangetoHTML(rng) & "<br>" & "<br>" & "Thank You," & _
"<br>" & "<br>" & .HTMLBody


.Display
End With
End If

Set OutApp = Nothing
Set OutMail = Nothing
End If
End With
On Error GoTo 0 ' reset error behaviour. Always do this as it is sticky!!

'delete temporary sheet '<<<<< comment this out if there is a problem with the output on the email, so you can see what the table looks like in excel
Application.DisplayAlerts = False 'you don't want to be asked if it is OK
wsTemp.Delete
Application.DisplayAlerts = True

​

 

[2000km12]

Thank you! I will take a look!