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 SubI 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.
