Save Meta Data in new workbook

[Satheesh Miryala]

Hi Forum,

I am working on a checklist project where i am suppose to create a checklist which sends automatic emails when the checkbox is checked from each row. i could able to create the VBA code and it runs perfectly. Now, i got the extra requirement where i need to save the Meta Data in a new excel workbook and save in the shared path on daily basis as per date and a consolidated sheet to be prepared which merges the data as the days go on.

The Meta Data columns are Email Sender Name, Assigned SLA for Sending email, Actual Time Stamp of email sent, Difference between the actual and assigned.

Could someone help me on this please.

My Code for email automation is :

Sub reminder1()
Dim lRow As Integer
Dim i As Integer
Dim toList As String
Dim eSubject As String
Dim eBody As String
Dim olNamespace As Outlook.Namespace




With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With


Sheets(1).Select
lRow = Cells(Rows.Count, 4).End(xlUp).Row


For i = 2 To lRow
For Each oleControl In Sheets("Sheet1").OLEObjects
If Range(oleControl.TopLeftCell.Address).Row = i Then
If oleControl.Object.Value = True Then


Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set olNamespace = Outlook.GetNamespace("MAPI")
toList = Cells(i, 3) 'gets the recipient from col B
eSubject = "Bonus Assignment"

eBody = "Hello All" & "," & vbNewLine & vbNewLine & _
"This is to remind you that the following task " & Cells(i, 6) & " " & "has been completed" & vbNewLine & vbNewLine & _
"Thanks & Regards" & vbNewLine & _
olNamespace.CurrentUser
On Error Resume Next
With OutMail
.To = toList
.CC = ""
.BCC = ""
.Subject = eSubject
.Body = eBody
.Display
'.Send
End With


On Error GoTo 0
Cells(i, 7) = "Mail Sent " 'Marks the row as "email sent in Column A"
Cells(i, 8).Value = olNamespace.CurrentUser
Cells(i, 9).Value = Date + Time
Set OutMail = Nothing
Set OutApp = Nothing
End If
End If
Next oleControl
Next i


ActiveWorkbook.Save


With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub