Code isnt working as it should

[ipbr21054]

Morning,
I am using the code supplied below.

The issue regards the red highlite part of the code.
Column E applied Red font to the inserted value, this is correct.

Column B i would enter a 17 digit value consisting of numbers & letters, when i leave the cell the 10th character should turn red, this is correct.

The issue that i have just noticed is any cell i click then leave the 10th character is also now shown as Red.
So looking at my worksheet if any cell value has more than 10 characters then the cell will have a red 10th character in it, this is wrong.

The only cell that should have any Red font in it would be column B and E

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim myStartCol As String
    Dim myEndCol As String
    Dim myStartRow As Long
    Dim myLastRow As Long
    Dim myRange As Range

    If Target.Cells.Count > 1 Then Exit Sub

    Application.ScreenUpdating = False

'   *** Specify columns to apply this to ***
    myStartCol = "A"
    myEndCol = "J"

'   *** Specify start row ***
    myStartRow = 7

'   Use first column to find the last row
    myLastRow = Cells(Rows.Count, myStartCol).End(xlUp).Row

'   Build range to apply this to
    Set myRange = Range(Cells(myStartRow, myStartCol), Cells(myLastRow, myEndCol))

'   Clear the color of all the cells in range
    myRange.Interior.ColorIndex = 6

'   Check to see if cell selected is outside of range
    If Intersect(Target, myRange) Is Nothing Then Exit Sub

'   Highlight the row and column that contain the active cell
    Range(Cells(Target.Row, myStartCol), Cells(Target.Row, myEndCol)).Interior.ColorIndex = 8
    Target.Interior.Color = vbGreen
    Target.Characters(Start:=10, Length:=1).Font.Color = -16776961
    Range("B7").Characters(Start:=10, Length:=1).Font.Color = -16776961
    Application.EnableEvents = False
    Select Case Mid(Range("B7").Value, 10, 1)
    Case Is = "S"
            Range("E7").Value = "1995"
    Case Is = "T"
            Range("E7").Value = "1996"
    Case Is = "V"
            Range("E7").Value = "1997"
    Case Is = "W"
            Range("E7").Value = "1998"
    Case Is = "X"
            Range("E7").Value = "1999"
    Case Is = "Y"
            Range("E7").Value = "2000"
    Case Is = "1"
            Range("E7").Value = "2001"
    Case Is = "2"
            Range("E7").Value = "2002"
    Case Is = "3"
            Range("E7").Value = "2003"
    Case Is = "4"
            Range("E7").Value = "2004"
    Case Is = "5"
            Range("E7").Value = "2005"
    Case Is = "6"
            Range("E7").Value = "2006"
    Case Is = "7"
            Range("E7").Value = "2007"
    Case Is = "8"
            Range("E7").Value = "2008"
    Case Is = "9"
            Range("E7").Value = "2009"
    Case Is = "A"
            Range("E7").Value = "2010"
    Case Is = "B"
            Range("E7").Value = "2011"
    Case Is = "C"
            Range("E7").Value = "2012"
    Case Is = "D"
            Range("E7").Value = "2013"
    Case Is = "E"
            Range("E7").Value = "2014"
    Case Is = "F"
            Range("E7").Value = "2015"
    Case Is = "G"
            Range("E7").Value = "2016"
    Case Is = "H"
            Range("E7").Value = "2017"
    Case Is = "J"
            Range("E7").Value = "2018"
    Case Is = "K"
            Range("E7").Value = "2019"
    End Select
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Range("E7").Font.Color = vbRed
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range
    Dim lr As Long
    lr = Cells(Rows.Count, "A").End(xlUp).Row
    On Error GoTo AllowEvents
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
        
    For Each c In Target
        If c.Row > 6 And c.Column < 11 And Not IsEmpty(c) Then
            If Not c.HasFormula Then
                c.Value = UCase(c.Value)
            Else
                c.Formula = Replace(c.Formula, "=", "=UPPER(") & ")"
            End If
        End If
    Next c

    If Target.CountLarge > 1000 Then GoTo AllowEvents
    
    If Not Intersect(Target, Range("B7:B" & lr)) Is Nothing Then
    
        For Each c In Intersect(Target, Range("B7:B" & lr))
            If (c.Row > 6) And (c.Row < lr) Then
                If Len(c.Value) <> 17 And Len(c.Value) > 0 Then
                    MsgBox "VIN MUST BE 17 CHARACTERS", vbCritical, "VIN CHARACTER COUNT MESSAGE"
                    c.Value = ""
                    c.Select
                    GoTo AllowEvents
                Else
                    c.Characters(Start:=10, Length:=1).Font.ColorIndex = 3
                End If
            Else
                  c.Characters(Start:=10, Length:=1).Font.ColorIndex = 3
            End If
        Next c
               If Range("B7") = "" Then Range("E7") = ""
    End If
AllowEvents:

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Range("B7").Characters(Start:=10, Length:=1).Font.ColorIndex = 3
End Sub

 

[davesexcel]

Target.Characters(Start:=10, Length:=1).Font.Color = -16776961

Is this not going to happen in columns A to J?

 

[ipbr21054]

Hi,
Column A:J should only be the cell colour for when i move around the worksheet.
It should have nothing to do with the Red font.

I will look when home.

 

[ipbr21054]

That seems to have sorted it,must of left it there by mistake.

Thanks