Selection change event code now to be used on change event code issue

I

ipbr21054

Well-known Member
Joined
Nov 16, 2010
Messages
5,738
Office Version
  1. 2007
Platform
  1. Windows
Hi,

I have placed a piece of working code from one worksheet into a new worksheet but now doesnt work work for me.
The worksheet it was taken from was a selection change event "code also works still" where now the worksheet its now in is a change event "doesnt work"

Column B will have a 17 character value entered into the cell.
The 10th character will be shown in RED.
Depending on the 10th character the value then in cell column I will also be RED.

Can you advise what i missed or need to add so no matter what cell etc i am in the code below will make sure and the 10th character in column B will be RED
The selection change code worked only for cell B8 as a new row was added each time.

I changed the range B8 to B8:B50 but still no joy

Code in place is shown below

Rich (BB code): 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim C As Range
    Dim LR As Long
    
    Range("B8").Characters(Start:=10, Length:=1).Font.Color = -16776961
    Application.EnableEvents = False
    Select Case Mid(Range("B8").Value, 10, 1)
    Case Is = "S"
            Range("I8").Value = "1995"
    Case Is = "T"
            Range("I8").Value = "1996"
    Case Is = "V"
            Range("I8").Value = "1997"
    Case Is = "W"
            Range("I8").Value = "1998"
    Case Is = "X"
            Range("I8").Value = "1999"
    Case Is = "Y"
            Range("I8").Value = "2000"
    Case Is = "1"
            Range("I8").Value = "2001"
    Case Is = "2"
            Range("I8").Value = "2002"
    Case Is = "3"
            Range("I8").Value = "2003"
    Case Is = "4"
            Range("I8").Value = "2004"
    Case Is = "5"
            Range("I8").Value = "2005"
    Case Is = "6"
            Range("I8").Value = "2006"
    Case Is = "7"
            Range("I8").Value = "2007"
    Case Is = "8"
            Range("I8").Value = "2008"
    Case Is = "9"
            Range("I8").Value = "2009"
    Case Is = "A"
            Range("I8").Value = "2010"
    Case Is = "B"
            Range("I8").Value = "2011"
    Case Is = "C"
            Range("I8").Value = "2012"
    Case Is = "D"
            Range("I8").Value = "2013"
    Case Is = "E"
            Range("I8").Value = "2014"
    Case Is = "F"
            Range("I8").Value = "2015"
    Case Is = "G"
            Range("I8").Value = "2016"
    Case Is = "H"
            Range("I8").Value = "2017"
    Case Is = "J"
            Range("I8").Value = "2018"
    Case Is = "K"
            Range("I8").Value = "2019"
    End Select
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Range("I8").Font.Color = vbRed

    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("B8:B" & LR)) Is Nothing Then
    
        For Each C In Intersect(Target, Range("B8: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("B8") = "" Then Range("E8") = ""
    End If
AllowEvents:

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Range("B8").Characters(Start:=10, Length:=1).Font.ColorIndex = 3
    
    Range("B8").Font.Size = 18
    Range("B8").Font.Bold = True
    Range("B8").HorizontalAlignment = xlCenter
    Range("B8").VerticalAlignment = xlCenter
    Range("B8").Font.Name = "Calibri"
    Range("B8").Borders.LineStyle = xlContinuous
    Range("B8").Borders.Weight = xlThin

End Sub
 

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)
Sort by date Sort by votes
Is this related to your other thread ?
www.mrexcel.com

Textbox character counr before submit

Evening, I have a userform where TextBox2 needs to have 17 characters entered. It must be 17 or show Msgbox. I am not sure if the code should be on that Textbox so when i leave it i see the Msgbox Or when i press the command button to transfer userform values to worksheet. I also paste into...
www.mrexcel.com www.mrexcel.com

Does the item in column B derive from a TextBox ?
- if so, how are you transferring the value from the textbox to the cell in column B ?
- please post any code that you are using
 
Upvote 0
Its the same worksheet yes.

The reason of the change from selection to change event was because sometimes in a previous row the 10th character had somehow changed to black from red,why or how ?????

So i thought to have a code to just automatically make sure that the 10th character was always red would solve it.
 
Upvote 0
Yongle said:
Does the item in column B derive from a TextBox ?
- if so, how are you transferring the value from the textbox to the cell in column B ?
- please post any code that you are using
Click to expand...

???
These questions are important
 
Upvote 0
TextBox2 sends 17 character value to cell B8

userform command button code

VBA Code: 
Private Sub CommandButton1_Click()
If Len(Me.TextBox2.Value) = 17 Then
    Dim i As Integer
    Dim X As Long
    Dim ControlsArr(1 To 8) As Variant
    
    
    For i = 1 To 8
        If i > 2 Then
            With Me.Controls("ComboBox" & i)
                If .ListIndex = -1 Then
                    MsgBox "YOU MUST COMPLETE ALL FIELDS", vbCritical, "MC LIST TRANSFER"
                    TextBox1.SetFocus
                    Exit Sub
                Else
                    ControlsArr(i) = .Value
                End If
            End With
        Else
            ControlsArr(i) = Me.Controls("TextBox" & i).Value
        End If
    Next i
        
        Application.ScreenUpdating = False
        
        With ThisWorkbook.Worksheets("MC LIST")
            .Range("A8").EntireRow.Insert Shift:=xlDown
            .Range("A8:I8").Borders.Weight = xlThin
            .Cells(8, 1).Resize(, UBound(ControlsArr)).Value = ControlsArr
            

        End With
        Range("B8").Select
        Range("A8").Select
        ActiveWorkbook.Save

        Application.ScreenUpdating = True
        MsgBox "Database Has Been Updated", vbInformation, "SUCCESSFUL MESSAGE"
        
       With ThisWorkbook.Worksheets("MC LIST")
      
       If .AutoFilterMode Then .AutoFilterMode = False
            X = .Cells(.Rows.Count, 1).End(xlUp).Row
            .Range("A7:I" & X).Sort Key1:=Range("A8"), Order1:=xlAscending, Header:=xlGuess
            .Range("B8").Select
            .Range("A8").Select
        End With
        
        Unload McListForm
    Else
        MsgBox "VIN MUST BE 17 CHARACTERS" & vbCr & vbCr & "DATABASE WAS NOT UPDATED", vbCritical, "MC LIST TRANSFER"
        TextBox2.SetFocus
    End If
End Sub
 
Upvote 0
Update the value in B and I when you transfer the value from the textbox like this
'this line is writes the value to B8
VBA Code: 
 .Cells(8, 1).Resize(, UBound(ControlsArr)).Value = ControlsArr
'INSERT this line immediately below it to make 10th character red
.Cells(8, 2).Characters(Start:=10, Length:=1).Font.Color = -16776961
'INSERT this line immediately below that to place value in column I
.Cells(8, 9 ).Value = GetYear(Mid(.Cells(8, 2).Value, 10, 1)

GetYear calls this function which must be placed in the same code window as CommandButton1_Click
VBA Code: 
Private Function GetYear(x As String) As Long
    Dim yr As Long
    Const myStr = "STVWXY123456789ABCDEFGHJK"
    x = UCase(x)
    yr = InStr(1, myStr, x)
    If yr > 0 Then GetYear = yr + 1994 Else GetYear = 9999
End Function
 
Upvote 0
This gives me a compile error

VBA Code: 
.Cells(8, 9).Value = GetYear(Mid(.Cells(8, 2).Value, 10, 1)
 
Upvote 0
oops - add a closing bracket :oops:
Rich (BB code): 
  .Cells(8, 9).Value = GetYear(Mid(.Cells(8, 2).Value, 10, 1))
 
Upvote 0
Thanks,

It doesnt turn 10th character red.

This is what ive got.

VBA Code: 
Private Sub CommandButton1_Click()
If Len(Me.TextBox2.Value) = 17 Then
    Dim i As Integer
    Dim x As Long
    Dim ControlsArr(1 To 8) As Variant
    
    
    For i = 1 To 8
        If i > 2 Then
            With Me.Controls("ComboBox" & i)
                If .ListIndex = -1 Then
                    MsgBox "YOU MUST COMPLETE ALL FIELDS", vbCritical, "MC LIST TRANSFER"
                    TextBox1.SetFocus
                    Exit Sub
                Else
                    ControlsArr(i) = .Value
                End If
            End With
        Else
            ControlsArr(i) = Me.Controls("TextBox" & i).Value
        End If
    Next i
        
        Application.ScreenUpdating = False
        
        With ThisWorkbook.Worksheets("MC LIST")
            .Range("A8").EntireRow.Insert Shift:=xlDown
            .Range("A8:I8").Borders.Weight = xlThin
            .Cells(8, 1).Resize(, UBound(ControlsArr)).Value = ControlsArr
            .Cells(8, 2).Characters(Start:=10, Length:=1).Font.Color = -16776961
            .Cells(8, 9).Value = GetYear(Mid(.Cells(8, 2).Value, 10, 1))

        End With
        Range("B8").Select
        Range("A8").Select
        ActiveWorkbook.Save

        Application.ScreenUpdating = True
        MsgBox "Database Has Been Updated", vbInformation, "SUCCESSFUL MESSAGE"
        
       With ThisWorkbook.Worksheets("MC LIST")
      
       If .AutoFilterMode Then .AutoFilterMode = False
            x = .Cells(.Rows.Count, 1).End(xlUp).Row
            .Range("A7:I" & x).Sort Key1:=Range("A8"), Order1:=xlAscending, Header:=xlGuess
            .Range("B8").Select
            .Range("A8").Select
        End With
        
        Unload McListForm
    Else
        MsgBox "VIN MUST BE 17 CHARACTERS" & vbCr & vbCr & "DATABASE WAS NOT UPDATED", vbCritical, "MC LIST TRANSFER"
        TextBox2.SetFocus
    End If
End Sub

Also this on the same editor page.

Code: 
Private Function GetYear(x As String) As Long
    Dim yr As Long
    Const myStr = "STVWXY123456789ABCDEFGHJK"
    x = UCase(x)
    yr = InStr(1, myStr, x)
    If yr > 0 Then GetYear = yr + 1994 Else GetYear = 9999
End Function
 
Upvote 0
ipbr21054 said:
It doesnt turn 10th character red.
Click to expand...
VBA Code: 
 .Cells(8, 2).Characters(Start:=10, Length:=1).Font.Color = -16776961
is your code line of code
- I tested it, and it does work
- so there must be something I do not know

To see what is going on ...
VBA Code: 
'BELOW this line
  .Cells(8, 9).Value = GetYear(Mid(.Cells(8, 2).Value, 10, 1))
'INSERT this line
Exit Sub

What is the value in B8 ?
Is the 10th character red or not ?
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
Using Defined name and/or direct formula in VBA
2
Replies
11
Views
413
Schturman
S
excelbytes
  • Solved
Data Validation Show Codes Only
2 3
Replies
20
Views
378
HighAndWilder
H
T
  • Question Question
Clear FIlters of Pivot Table after Cell Value Changes
Replies
4
Views
443
Alex Blakenburg
A
T
  • Question Question
Ensure that the filter is reset once cell value changes
Replies
4
Views
254
thatfarooq
T
E
  • Question Question
Copy Cell as Hyperlink to another cell
Replies
1
Views
241
eli_m
E

Forum statistics

Threads
1,223,912
Messages
6,175,340
Members
452,637
Latest member
Ezio2866

Share this page

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