Option Explicit
'Set the name of the sheet containing the employee data.
Const m_strSHEET_NAME = "Sheet1"
Public Sub SendEmails()
Const olMailItem = 0
Dim astrManagerDetails() As String
Dim astrEmployeeNames() As String
Dim strManagerEmail As String
Dim lngManagerCount As Long
Dim strManagerName As String
Dim objOutlookApp As Object
Dim lngManagerNum As Long
Dim objMailItem As Object
On Error GoTo ErrHandler
astrManagerDetails = GetManagerDetails(lngManagerCount)
Set objOutlookApp = CreateObject("Outlook.Application")
For lngManagerNum = 1 To lngManagerCount
strManagerName = astrManagerDetails(1, lngManagerNum)
strManagerEmail = astrManagerDetails(2, lngManagerNum)
astrEmployeeNames = GetEmployeeNames(strManagerName)
Set objMailItem = objOutlookApp.CreateItem(olMailItem)
objMailItem.To = strManagerEmail
objMailItem.Body = Join(astrEmployeeNames, vbCrLf)
objMailItem.Display
' objMailItem.Send
Next lngManagerNum
ExitProc:
Set objOutlookApp = Nothing
Set objMailItem = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitProc
End Sub
Private Function GetManagerDetails(ByRef lngManagerCount As Long) As String()
Dim astrManagerDetails() As String
Dim clnManagers As New Collection
Dim lngLastRow As Long
Dim lngRowNum As Long
With ThisWorkbook.Sheets(m_strSHEET_NAME)
lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
lngManagerCount = 0
For lngRowNum = 2 To lngLastRow
On Error Resume Next
clnManagers.Add .Cells(lngRowNum, "B").Value, CStr(.Cells(lngRowNum, "B").Value)
If Err.Number <> 0 Then GoTo ContinueFor
On Error GoTo 0
lngManagerCount = lngManagerCount + 1
ReDim Preserve astrManagerDetails(1 To 2, 1 To lngManagerCount)
astrManagerDetails(1, lngManagerCount) = .Cells(lngRowNum, "B").Value
astrManagerDetails(2, lngManagerCount) = .Cells(lngRowNum, "C").Value
ContinueFor:
Next lngRowNum
End With
GetManagerDetails = astrManagerDetails
End Function
Private Function GetEmployeeNames(ByVal strManagerName As String) As String()
Dim astrEmployeeNames() As String
Dim lngEmployeeCount As Long
Dim lngLastRow As Long
Dim lngRowNum As Long
With ThisWorkbook.Sheets(m_strSHEET_NAME)
lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For lngRowNum = 2 To lngLastRow
If .Cells(lngRowNum, "B").Value = strManagerName Then
lngEmployeeCount = lngEmployeeCount + 1
ReDim Preserve astrEmployeeNames(1 To lngEmployeeCount)
astrEmployeeNames(lngEmployeeCount) = .Cells(lngRowNum, "A").Value
End If
Next lngRowNum
End With
GetEmployeeNames = astrEmployeeNames
End Function