Check list for email send

antros48

New Member
Joined
Mar 2, 2020
Messages
1
Office Version
  1. 2019
Platform
  1. Windows
VBA Code:
Private Sub CheckBox1_Click()

Dim eSubject As String

Dim eBody As String

Dim names As String

Dim linked As Range

Dim linked2 As Range

Dim foundrng As Range

Dim dashpos As Long

Dim user_name As String

Dim user As String

dashpos = InStr(1, username, "(")

user_name = Left(username, dashpos - 2)

Set linked = Worksheets(1).Range(CheckBox1.LinkedCell)

 

lrow_preparer = Worksheets(2).Cells(Rows.Count, 2).End(xlUp).Row

lrow_reviewer = Worksheets(2).Cells(Rows.Count, 5).End(xlUp).Row

lrow_partner = Worksheets(2).Cells(Rows.Count, 8).End(xlUp).Row

lrow_eqcr = Worksheets(2).Cells(Rows.Count, 11).End(xlUp).Row

 

Names_preparer = Join(Application.Transpose(Worksheets(2).Range("C1:C" & lrow_preparer)), ";")

Names_reviewer = Join(Application.Transpose(Worksheets(2).Range("F1:F" & lrow_reviewer)), ";")

Names_partner = Join(Application.Transpose(Worksheets(2).Range("I1:I" & lrow_partner)), ";")

 

With Application

    .ScreenUpdating = False

    .EnableEvents = False

    .DisplayAlerts = False

End With

 

With Worksheets(2).Range("b1:b" & lrow_preparer)

    Set foundrng = .Find(user_name)

    If foundrng Is Nothing Then

GoTo flag1

 

'

'

'              ElseIf Me.CheckBox1.Value = True Then

'                                    Me.CheckBox1.TopLeftCell.Offset(1, 0).Value = Excel.Application.username

'                                    Me.CheckBox1.TopLeftCell.Offset(1, 0).Select

'                                    ActiveCell.Offset(0, 1).Value = Format(Date, "dd-mmm-yyyy")

'                                    Set OutApp = CreateObject("Outlook.Application")

'                                    Set OutMail = OutApp.CreateItem(0)

'                                    names = Names_preparer

'                                    eSubject = Me.CheckBox1.TopLeftCell.Offset(0, -2).Text

'                                    eBody = "<BODY style=font-size:10pt;font-family:Verdana>Dear Reviewers,<p>The Technical Note for " & eSubject & " is ready for your review and comments.<p>Thank you.</BODY>"

'                                    On Error Resume Next

'                                    With OutMail

'                                        .to = names

'                                        .CC = ""

'                                        .BCC = ""

'                                        .Subject = eSubject

'                                        .BodyFormat = olFormatHTML

'                                        .Display

'                                        .HTMLBody = eBody & .HTMLBody

'                                        '.Send

'                                    End With

'                                    On Error GoTo 0

'                                    Set OutMail = Nothing

'                                    Set OutApp = Nothing

'                            ''Me.CheckBox1.Enabled = False

                            End If

 

End With

    ActiveWorkbook.Save

 

    With Application

        .ScreenUpdating = True

        .EnableEvents = True

        .DisplayAlerts = True

    End With

 

flag1:

CheckBox1.Value = False

MsgBox ("You are not authorized for this action.")

 

End Sub

Private Sub Checkbox2_Click()

Dim eSubject As String

Dim eBody As String

Dim names As String

Dim linked As Range

Dim linked2 As Range

Dim foundrng As Range

Dim dashpos As Long

Dim user_name As String

Dim user As String

dashpos = InStr(1, username, "(")

user_name = Left(username, dashpos - 2)

Set linked = Worksheets(1).Range(CheckBox2.LinkedCell)

eSubject = Me.CheckBox2.TopLeftCell.Offset(0, -4).Text

lrow_preparer = Worksheets(2).Cells(Rows.Count, 2).End(xlUp).Row

lrow_reviewer = Worksheets(2).Cells(Rows.Count, 5).End(xlUp).Row

lrow_partner = Worksheets(2).Cells(Rows.Count, 8).End(xlUp).Row

lrow_eqcr = Worksheets(2).Cells(Rows.Count, 11).End(xlUp).Row

 

Names_preparer = Join(Application.Transpose(Worksheets(2).Range("C1:C" & lrow_preparer)), ";")

Names_reviewer = Join(Application.Transpose(Worksheets(2).Range("F1:F" & lrow_reviewer)), ";")

Names_partner = Join(Application.Transpose(Worksheets(2).Range("I1:I" & lrow_partner)), ";")

 

With Application

    .ScreenUpdating = False

    .EnableEvents = False

    .DisplayAlerts = False

End With

 

With Worksheets(2).Range("e1:e" & lrow_reviewer)

    Set foundrng = Range("e1:e" & lrow_reviewer).Find(user_name)

    If foundrng Is Nothing Then

        MsgBox "You are not authorized for this action."

        CheckBox2.Value = False

        Exit Sub

 

       ElseIf Me.CheckBox1.Value = True Then

                                If Me.CheckBox2.Value = True And Me.CheckBox3.Value = False Then

                                            Me.CheckBox2.TopLeftCell.Offset(1, 0).Value = Excel.Application.username

                                            Me.CheckBox2.TopLeftCell.Offset(1, 0).Select

                                            ActiveCell.Offset(0, 1).Value = Format(Date, "dd-mmm-yyyy")

                                            Set OutApp = CreateObject("Outlook.Application")

                                            Set OutMail = OutApp.CreateItem(0)

                                            names = Names_reviewer

                                            eSubject = Me.CheckBox2.TopLeftCell.Offset(0, -4).Text

                                            eBody = "<BODY style=font-size:10pt;font-family:Verdana>Dear Review Team,<p>The Technical Note for " & eSubject & " is ready for your review and comments.<p>Thank you.</BODY>"

                                            On Error Resume Next

                                            With OutMail

                                                .to = names

                                                .CC = ""

                                                .BCC = ""

                                                .Subject = eSubject

                                                .BodyFormat = olFormatHTML

                                                .Display

                                                .HTMLBody = eBody & .HTMLBody

                                                '.Send

                                            End With

                                            On Error GoTo 0

                                            Set OutMail = Nothing

                                            Set OutApp = Nothing

                                            ''Me.CheckBox2.Enabled = False

                                            Else

                                            Me.CheckBox2.TopLeftCell.Offset(1, 0).Value = Excel.Application.username

                                            Me.CheckBox2.TopLeftCell.Offset(1, 0).Select

                                            ActiveCell.Offset(0, 1).Value = Format(Date, "dd-mmm-yyyy")

                                            Set OutApp = CreateObject("Outlook.Application")

                                            Set OutMail = OutApp.CreateItem(0)

                                            names = Names_partner

                                            eSubject = Me.CheckBox2.TopLeftCell.Offset(0, -4).Text

                                            eBody = "<BODY style=font-size:10pt;font-family:Verdana>Dear Partners,<p>The Technical Note for " & eSubject & " is ready for your approval.<p>Thank you.</BODY>"

                                            On Error Resume Next

                                            With OutMail

                                                .to = names

                                                .CC = Names_preparer & ";" & Names_reviewer

                                                .BCC = ""

                                                .Subject = eSubject

                                                .BodyFormat = olFormatHTML

                                                .Display

                                                .HTMLBody = eBody & .HTMLBody

                                                '.Send

                                            End With

                                            On Error GoTo 0

                                            Set OutMail = Nothing

                                            Set OutApp = Nothing

                                            ''Me.CheckBox2.Enabled = False

                                            End If

 

                            Else

                            MsgBox "The Technical Note " & eSubject & " has not been prepared yet."

                            CheckBox2.Value = False

                            Exit Sub

                            End If

                          

 

End With

    ''ActiveWorkbook.Save

 

    With Application

        .ScreenUpdating = True

        .EnableEvents = True

        .DisplayAlerts = True

    End With

 

End Sub

 

Private Sub CheckBox3_Click()

Dim eSubject As String

Dim eBody As String

Dim names As String

Dim linked As Range

Dim linked2 As Range

Dim foundrng As Range

Dim dashpos As Long

Dim user_name As String

Dim user As String

dashpos = InStr(1, username, "(")

user_name = Left(username, dashpos - 2)

Set linked = Worksheets(1).Range(CheckBox3.LinkedCell)

eSubject = Me.CheckBox2.TopLeftCell.Offset(0, -4).Text

lrow_preparer = Worksheets(2).Cells(Rows.Count, 2).End(xlUp).Row

lrow_reviewer = Worksheets(2).Cells(Rows.Count, 5).End(xlUp).Row

lrow_partner = Worksheets(2).Cells(Rows.Count, 8).End(xlUp).Row

lrow_eqcr = Worksheets(2).Cells(Rows.Count, 11).End(xlUp).Row

 

Names_preparer = Join(Application.Transpose(Worksheets(2).Range("C1:C" & lrow_preparer)), ";")

Names_reviewer = Join(Application.Transpose(Worksheets(2).Range("F1:F" & lrow_reviewer)), ";")

Names_partner = Join(Application.Transpose(Worksheets(2).Range("I1:I" & lrow_partner)), ";")

 

With Application

    .ScreenUpdating = False

    .EnableEvents = False

    .DisplayAlerts = False

End With

 

With Worksheets(2).Range("E1:E" & lrow_reviewer)

    Set foundrng = Range("E1:E" & lrow_reviewer).Find(user_name)

    If foundrng Is Nothing Then

        MsgBox "You are not authorized for this action."

        CheckBox3.Value = False

       Else

                            If Me.CheckBox1.Value = True Then

                                If Me.CheckBox3.Value = True Then

                                  

                                            If Me.CheckBox2.Value = False Then

                                            Me.CheckBox3.TopLeftCell.Offset(1, 0).Value = Excel.Application.username

                                            Me.CheckBox3.TopLeftCell.Offset(1, 0).Select

                                            ActiveCell.Offset(0, 1).Value = Format(Date, "dd-mmm-yyyy")

                                            Set OutApp = CreateObject("Outlook.Application")

                                            Set OutMail = OutApp.CreateItem(0)

                                            names = Names_reviewer

                                            eSubject = Me.CheckBox3.TopLeftCell.Offset(0, -6).Text

                                            eBody = "<BODY style=font-size:10pt;font-family:Verdana>Dear Review Team,<p>The Technical Note for " & eSubject & " is ready for your review and comments.<p>Thank you.</BODY>"

                                            On Error Resume Next

                                            With OutMail

                                                .to = names

                                                .CC = ""

                                                .BCC = ""

                                                .Subject = eSubject

                                                .BodyFormat = olFormatHTML

                                                .Display

                                                .HTMLBody = eBody & .HTMLBody

                                                '.Send

                                            End With

                                            On Error GoTo 0

                                            Set OutMail = Nothing

                                            Set OutApp = Nothing

                                            ''Me.CheckBox3.Enabled = False

                                            Else

                                            Me.CheckBox3.TopLeftCell.Offset(1, 0).Value = Excel.Application.username

                                            Me.CheckBox3.TopLeftCell.Offset(1, 0).Select

                                            ActiveCell.Offset(0, 1).Value = Format(Date, "dd-mmm-yyyy")

                                            Set OutApp = CreateObject("Outlook.Application")

                                            Set OutMail = OutApp.CreateItem(0)

                                            names = Names_partner

                                            eSubject = Me.CheckBox3.TopLeftCell.Offset(0, -6).Text

                                            eBody = "<BODY style=font-size:10pt;font-family:Verdana>Dear Partners,<p>The Technical Note for " & eSubject & " is ready for your approval.<p>Thank you.</BODY>"

                                            On Error Resume Next

                                            With OutMail

                                                .to = names

                                                .CC = Names_preparer & ";" & Names_reviewer

                                                .BCC = ""

                                                .Subject = eSubject

                                                .BodyFormat = olFormatHTML

                                                .Display

                                                .HTMLBody = eBody & .HTMLBody

                                                '.Send

                                            End With

                                           On Error GoTo 0

                                            Set OutMail = Nothing

                                            Set OutApp = Nothing

                                            ''Me.CheckBox3.Enabled = False

                                            End If

                            End If

                            Else

                            MsgBox "The Technical Note " & eSubject & " has not been prepared yet."

                            CheckBox3.Value = False

                            End If

                          

 

    End If

End With

    ''ActiveWorkbook.Save

 

    With Application

        .ScreenUpdating = True

        .EnableEvents = True

        .DisplayAlerts = True

    End With

 

 

End Sub
Hi all,
I am trying to create a checklist type of document for project management. The idea is to have a lot of rows each of which deals with a different project that has to be done by some members. Each row will have 4 different checkboxes. The first checkbox has to be checked by only the preparer of the task and if this is happen successfully then an email is sent to the reviewers group to open the document and check for their corresponding checklist of that row. When both reviewers check their boxes then an email is sent to the partner of this task to check that everything is ok and tick their own checkbox.
I managed to write down the code for the three of the four boxes and i stopped because i had some bugs such as a message box appearing twice or very slow execution.Also i am not sure whether this will be the most appropriate solution considering that i will have to include around 30 different rows with tasks each with 4 different checkboxes (preparer, reviewer1, reviewer2, parner). Is there a more generic way to define my functions within the code so that I could assign macro to recognize when the previous checkbox is ticked so as to move to the next one?
Find my file attached. Thank you for your help.
 

Some videos you may like

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.

Watch MrExcel Video

Forum statistics

Threads
1,113,835
Messages
5,544,593
Members
410,623
Latest member
RusHartley
Top