ipbr21054
Well-known Member
- Joined
- Nov 16, 2010
- Messages
- 5,199
- Office Version
- 2007
- Platform
- 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.
When i leave the cell B7 the 10th character is shown red.
The code in use is shown below.
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.
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
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)