10th character in test to be Red

[ipbr21054]

Hi,
I have a working code that allows the 10th character to be shown in red whilst the rest is shown in black for cell B7
I insert a new row using the code shown below and enter values in that row.

Private Sub InsertNewRow_Click()
Rows("7:7").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A7").Select
Range("A7:J7").Font.Size = 18
Range("A7:J7").Font.Bold = True
Range("A7:K7").Interior.ColorIndex = 6
Range("A7:J7").Borders.LineStyle = xlContinuous
Range("A7:J7").Borders.Weight = xlThin
Range("A7:J7").HorizontalAlignment = xlCenter
Range("A7:J7").VerticalAlignment = xlCenter
Range("A7:J7").Name = "Calibri"
Range("A7:J7").RowHeight = 30
End Sub

When i leave the cell B7 the 10th character is shown red.
The code in use is shown below.

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

    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

Currently if i see a mistake in say cell B50 & retype the value again the 10th character isnt shown as red.
To make this work i need to insert a new row,copy all the values, then delete the row which has the error on.

Changing the code shown below "Added B50" then returns a RTE 13 Type Mismatch.

Select Case Mid(Range("B7:B50").Value, 10, 1)

 

[ipbr21054]

If you mean this then yes

c.Characters(Start:=10, Length:=1).Font.ColorIndex = 3

This is what happens WITHOUT the code.
Current range A7:A18
Type in cell B18 a 17 character code.
I leave the cell but all characters are black.
I select the cell now 10th character turns red.

I select cell B30, B 44, B50 and type a 17 character value
I leave the cell and all characters are black
"This is correct as last row of values was row18"

This is what happens WITH the code
Current range A7:A18
Code is inserted here.

            Else
                c.Formula = Replace(c.Formula, "=", "=UPPER(") & ")"
            End If
            c.Characters(Start:=10, Length:=1).Font.ColorIndex = 3
        End If
    Next c
    
    If Target.CountLarge > 1000 Then GoTo AllowEvents

I Type in cell B18 a 17 character code.
I leave the cell & straight away the 10th character turn red "GOOD"
I select cell B30, B 44, B50 and type a 17 character value
I leave the cell and the 10th character turns red "BAD"
"This is INCORRECT because the last row of values was row 18" so the red character code shouldnt apply to any other cell outside of row 18 at present

 

[DanteAmor]

In SelectionChange Event

myStartCol = "A"

In Change Event:

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

 

[ipbr21054]

Thats it, now working as required.

Thanks

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.