10th character in test to be Red

ipbr21054

Well-known Member
Joined
Nov 16, 2010
Messages
5,199
Office Version
  1. 2007
Platform
  1. Windows
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.

Code:
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.

Code:
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.

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

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Try this

VBA Code:
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
 
Upvote 0
Hi,
Nearly there.
I am able to edit the error in the B cell.i then leave that cell but it only changed red if i then that cell again ??

Here is my worksheet change event code
This allows the 10th character to turn red BUT ONLY within the range of which has values in it.
Currently B7:B18 so nothing happens if i type after B18 in respect of red that is.

I know you know this by looking at the code but wrote it anyway

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range
    Dim lr As Long
    lr = Cells(Rows.Count, "B").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
            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
 
Upvote 0
Firts, In the Change event, change this line:

myStartCol = "A"

By this:
myStartCol = "B"

Then:

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

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range
    Dim lr As Long
    lr = Cells(Rows.Count, "B").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
            c.Characters(Start:=10, Length:=1).Font.ColorIndex = 3
        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
            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
 
Upvote 0
Thanks,

Can you advise where the myStartcol A/B is as i dont see it ??
 
Upvote 0
Sorry, is in event SelectionChange:

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"
 
Upvote 0
Ok,
It is A because that is for the cell row / active cell colour change.
So A is correct for that.

My range with data at present is A7:H18
But as i use the new row button H18 will become 19,20,21 etc etc

The code for 10th character change should ONLY work within the range which has data & not outside that range.

So my range is A7:H18
I add the code
VBA Code:
c.Characters(Start:=10, Length:=1).Font.ColorIndex = 3
I then type in cell 19, 27, 44 and the 10th character turns red.
This should not happen because the last row with values at present is row 18
If i remove that code all is ok but then i need to leave the cell then select the cell for its colour to change
 
Upvote 0
I don't understand when you want to change the character.
But you can fix it yourself.
Put this line in the place where you want it to happen.

c.Characters(Start:=10, Length:=1).Font.ColorIndex = 3
 
Upvote 0
The character needs to turn red after leaving the active cell in B

My last row at present with values is row 18 so if i type in any B cell after row 18 there should be no red character change.

Its not a case of when i want to change it but more of where.

See my photo example.
Row 18 is the last row with values so anything less than 18 will allow the red colour change BUT anything after row 18 it shouldnt work because the code should be able to work for row with values
 

Attachments

  • 5992.jpg
    5992.jpg
    12 KB · Views: 3
Upvote 0
Did you try the code of the change event that I put in the post #4?
 
Upvote 0

Forum statistics

Threads
1,213,534
Messages
6,114,186
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top