Results 1 to 2 of 2
  1. #1
    New Lounger
    Join Date
    Sep 2015
    Posts
    10
    Thanks
    2
    Thanked 0 Times in 0 Posts

    Help Changing the Colour Index depending on DDD

    Good Morning,


    My experience of VBA is still limited so any help regarding the below would be highly appreciated.


    I've created the below script which will tick the target cell and enter a user stamp subject to the target cell being in the same column as the current DDD.
    Simultaneously range 1 to 3 (ABC) change colour once the target cell has been ticked.


    I'm looking to have a different colour for each day, for example MON = 37 TUE = 38 WED = 39 etc..


    Thank you in advance.


    Code:
    Private Sub SendEmail(EmailSubject, EmailBody)
            Dim OutApp As Outlook.Application
            Dim OutMail As Outlook.MailItem
            Dim MyReci As Outlook.Recipient
    
    
            Set OutApp = New Outlook.Application
            Set OutMail = OutApp.CreateItem(olMailItem)
            
            With OutMail
                .Recipients.Add ("blank")
                .Subject = EmailSubject
                .Body = EmailBody
                .Display
            End With
    End Sub
    
    
    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
        If Cells(2, Target.Column).Value = Format(Now(), "DDD") And Cells(Target.Row, 1) <> "" Then
            If Target.Value = "" Then
                Target.Value = ""
                Target.Font.Name = "Wingdings"
                Target.Cells.Offset(0, 1).Value = Environ("UserName")
                Range(Cells(Target.Row, 1), Cells(Target.Row, 3)).Interior.ColorIndex = 37
                If Cells(Target.Row, 2).Value = "Send e-mail to C&R team" Then
                    Answer = MsgBox("Did any errors occur?", vbYesNo, Cells(Target.Row, 3).Value)
                    If Answer = vbYes Then
                        EmailSubject = Cells(Target.Row, 3).Value & "- PLEASE READ"
                        EmailBody = "Dear All," & vbNewLine & vbNewLine & Cells(Target.Row, 3).Value & "Completed, with the following errors" & vbNewLine & vbNewLine & "<<Enter Errors Here>>" & vbNewLine & vbNewLine & "Kind Regards" & vbNewLine & vbNewLine & Application.UserName & vbNewLine & "Change and Release"
                        SendEmail EmailSubject, EmailBody
                    Else
                        EmailSubject = Cells(Target.Row, 3).Value & "- OK"
                        EmailBody = "Dear All," & vbNewLine & vbNewLine & Cells(Target.Row, 3).Value & "completed with no errors" & vbNewLine & vbNewLine & "Kind Regards" & vbNewLine & vbNewLine & Application.UserName & vbNewLine & "Change and Release"
                        SendEmail EmailSubject, EmailBody
                    End If
                End If
            Else
                Target.Value = ""
                Target.Cells.Offset(0, 1).Value = ""
                If (Target.Row / 2) = Int(Target.Row / 2) Then
                    Range(Cells(Target.Row, 1), Cells(Target.Row, 3)).Interior.ColorIndex = 35
                Else
                    Range(Cells(Target.Row, 1), Cells(Target.Row, 3)).Interior.ColorIndex = None
                End If
            End If
        End If
    End Sub

  2. #2
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,436
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    BLG,

    Not exactly sure what you are trying to do but a few suggestions:

    1. Create a variable to hold the Target.Row value so you only have to calculate it once.
    2. Use the Mod operator to save a calculation.
    3. Use the Line Continuation character (_) to make your code easier to read.


    Code:
    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
        Dim CurRow as Long
    	
        CurRow = Target.Row
    	
        If Cells(2, Target.Column).Value = Format(Now(), "DDD") And Cells(CurrRow, 1) <> "" Then
            If Target.Value = "" Then
                Target.Value = ""
                Target.Font.Name = "Wingdings"
                Target.Cells.Offset(0, 1).Value = Environ("UserName")
                Range(Cells(CurrRow, 1), Cells(CurrRow, 3)).Interior.ColorIndex = 37
                If Cells(CurrRow, 2).Value = "Send e-mail to C&R team" Then
                    Answer = MsgBox("Did any errors occur?", vbYesNo, Cells(CurrRow, 3).Value)
                    If Answer = vbYes Then
                        EmailSubject = Cells(CurrRow, 3).Value & "- PLEASE READ"
                        EmailBody = "Dear All," & vbNewLine & vbNewLine & Cells(CurrRow, 3).Value & _
                                    "Completed, with the following errors" & vbNewLine & vbNewLine & _
                                    "<<Enter Errors Here>>" & vbNewLine & vbNewLine & _
                                    "Kind Regards" & vbNewLine & vbNewLine & Application.UserName & _
                                    vbNewLine & "Change and Release"
                        SendEmail EmailSubject, EmailBody
                    Else
                        EmailSubject = Cells(CurrRow, 3).Value & "- OK"
                        EmailBody = "Dear All," & vbNewLine & vbNewLine & Cells(CurrRow, 3).Value & _
                                    "completed with no errors" & vbNewLine & vbNewLine & _
                                    "Kind Regards" & vbNewLine & vbNewLine & Application.UserName & _
                                    vbNewLine & "Change and Release"
                        SendEmail EmailSubject, EmailBody
                    End If
                End If
            Else
                Target.Value = ""
                Target.Cells.Offset(0, 1).Value = ""
                If (CurrRow mod 2) = 0 Then
                    Range(Cells(CurrRow, 1), Cells(CurrRow, 3)).Interior.ColorIndex = 35
                Else
                    Range(Cells(CurrRow, 1), Cells(CurrRow, 3)).Interior.ColorIndex = None
                End If
            End If
        End If
    End Sub
    HTH
    Last edited by RetiredGeek; 2016-01-26 at 09:30.
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •