ipbr21054
Well-known Member
- Joined
- Nov 16, 2010
- Messages
- 5,699
- Office Version
- 2007
- Platform
- Windows
Evening,
I currently have the working code supplied below in use,
This is how it works.
I complete each cell with values in row 7 & i see cell B7 10th character change to red & also the value in cell E7 show in red.
The red part of the code is applied from values entered into the cell B7 BUT i have had a user lean on the keyboard & delete the value from say cell B25 He thought by typing the value back into the cell B25 would work but obviously this then doesnt allow the 10th character to change to red.
The only way at present is to re-enter the customer into row B7
I still need to insert a new row & start entering values in row 7 BUT can we also have a safety net where should leaning on the keyboard happen again the value can just be entered into that cell & for the 10th character turn red.
The text shown in red below was changed from just a specific cell to a range of cells but that just gave me a run time error type mismatch.
You might need this code also.
I currently have the working code supplied below in use,
This is how it works.
I complete each cell with values in row 7 & i see cell B7 10th character change to red & also the value in cell E7 show in red.
The red part of the code is applied from values entered into the cell B7 BUT i have had a user lean on the keyboard & delete the value from say cell B25 He thought by typing the value back into the cell B25 would work but obviously this then doesnt allow the 10th character to change to red.
The only way at present is to re-enter the customer into row B7
I still need to insert a new row & start entering values in row 7 BUT can we also have a safety net where should leaning on the keyboard happen again the value can just be entered into that cell & for the 10th character turn red.
The text shown in red below was changed from just a specific cell to a range of cells but that just gave me a run time error type mismatch.
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[COLOR=#ff0000]("B7")[/COLOR].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[COLOR=#ff0000]("E7")[/COLOR].Font.Color = vbRed
End Sub
You might need this code also.
Code:
Private Sub Worksheet_Change(ByVal Target As Range) Dim c As Range
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("B:B")) Is Nothing Then
For Each c In Intersect(Target, Range("B:B"))
If c.Row > 6 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
Last edited: