Getting information from you is like drawing teeth! However the following assumes you have a workbook "C:\Path\IDList.xlsx" with worksheet ("Sheet1") with the employee numbers in column 1 and the recipient of the messages in column 2 and will forward the message to all the records, changing the subject each time. Use the test macro to test it with a message in your inbox or run it as a script from a rule. It will be better not to have Outlook set to send messages immediately while testing!
Option Explicit
Sub TestProcess()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
Distribute olMsg
lbl_Exit:
Exit Sub
End Sub
Sub Distribute(olItem As MailItem)
Const strWorkbook As String = "C:\Path\IDList.xlsx"
Const strSheet As String = "Sheet1"
Dim vSubject As Variant
Dim sTo As String, sID As String
Dim strSubject As String
Dim olFwd As MailItem
Dim arr() As Variant
Dim i As Integer
With olItem
If TypeName(olItem) = "MailItem" Then
vSubject = Split(.Subject, "-")
If Not UBound(vSubject) = 2 Then GoTo lbl_Exit
If Not IsDate(Trim(vSubject(2))) Then GoTo lbl_Exit
arr = xlFillArray(strWorkbook, strSheet)
For i = 0 To UBound(arr, 2)
sID = arr(0, i)
sTo = arr(1, i)
Set olFwd = olItem.Forward
strSubject = sID & " -" & vSubject(1) & "-" & vSubject(2)
With olFwd
.Subject = strSubject
.To = sTo
.Display 'remove after testing
'.Send 'restore after testing
End With
Next i
End If
End With
lbl_Exit:
Exit Sub
End Sub
Private Function xlFillArray(strWorkbook As String, _
strWorksheetName As String) As Variant
Dim RS As Object
Dim CN As Object
Dim iRows As Long
strWorksheetName = strWorksheetName & "$]"
Set CN = CreateObject("ADODB.Connection")
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
Set RS = CreateObject("ADODB.Recordset")
RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1
With RS
.MoveLast
iRows = .RecordCount
.MoveFirst
End With
xlFillArray = RS.GetRows(iRows)
If RS.State = 1 Then RS.Close
Set RS = Nothing
If CN.State = 1 Then CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function