Please can you advise on how to simplify this code

I

ipbr21054

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

As per title.
Thanks

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Dim cel As Range
Dim ns As Variant
Set ws = Sheets("MC LIST")
For Each cel In ws.Range("B8", ws.Range("B" & ws.Rows.Count).End(xlUp))
If Len(cel) > 9 Then cel.Characters(Start:=10, Length:=1).Font.ColorIndex = 3
Next cel

    If Target.Cells.Count > 1 Then Exit Sub
    
    Application.ScreenUpdating = False

Application.EnableEvents = False
Select Case Mid(Range("B8").Value, 10, 1)
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.EnableEvents = True


End Sub
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
Sort by date Sort by votes
It's already as simple as it can get, maybe this is what you mean?
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
If Target.Address(0, 0) = "B8" Then
    If Len(Target) > 9 Then Target.Characters(Start:=10, Length:=1).Font.ColorIndex = 3
        Select Case Mid(Range("B8").Value, 10, 1)
        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
End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
In addation to the previous post, perhaps something like
VBA Code: 
    Case Is = "X"
            Range("I8").Value = "1999"
    Case Is = "Y"
            Range("I8").Value = "2000"
    Case Is = "1", "2", "3", "4", "5", "6", "7", "8", "9"
            Range("I8").Value = CStr(2000 + CInt(Mid(Range("B8").Value, 10, 1)))
    Case Is = "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K"
            Range("I8").Value = CStr(1945 + CLng(Asc(Mid(Range("B8").Value, 10, 1))))
 
Upvote 0
I thought along the lines like this that @DanteAmor used


VBA Code: 
      ns = Array("Y", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", _
                 "D", "E", "F", "G", "H", "J", "K", "L", "M", "N", "P", "R", "S")
      For i = 0 To UBound(ns)
        If Mid(Range("B8").Value, 10, 1) = ns(i) Then
          Range("I8").Value = "" & 2000 + i
          Exit For
        End If
      Next

      Application.EnableEvents = False
 
Upvote 0
You are free to use whatever suits your needs :)
 
Upvote 0
Try

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet, cel As Range, ns As Variant, V As String, Marker As String
    Set ws = Sheets("MC LIST")
    For Each cel In ws.Range("B8", ws.Range("B" & ws.Rows.Count).End(xlUp))
        If Len(cel) > 9 Then cel.Characters(Start:=10, Length:=1).Font.ColorIndex = 3
    Next cel

    If Target.Cells.Count > 1 Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Marker = Mid(Range("B8").Value, 10, 1)
    Select Case Marker
        Case "X":           V = "1999"
        Case "Y":           V = "2000"
        Case 1 To 9:        V = CStr(2000 + Marker)
        Case "A" To "K":    V = CStr(2010 + Asc(Marker) - 65)
    End Select
    Range("I8").Value = V
    Application.EnableEvents = True
End Sub
 
Upvote 0
Slightly more compact solution...
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet, cel As Range, x As String
    Set ws = Sheets("MC LIST")
    For Each cel In ws.Range("B8", ws.Range("B" & ws.Rows.Count).End(xlUp))
        If Len(cel) > 9 Then cel.Characters(Start:=10, Length:=1).Font.ColorIndex = 3
    Next cel

    If Target.Cells.Count > 1 Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    x = "XY123456789ABCDEFGHJKLMNOPQRSTUVW"
    Range("I8").Value = CStr(1998 + InStr(1, x, Mid(Range("B8").Value, 10, 1), vbBinaryCompare))
    
    Application.EnableEvents = True
End Sub
 
Upvote 0
Borrowing a line from @GWteB
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
If Target.Address(0, 0) = "B8" Then
    If Len(Target) > 9 Then Target.Characters(Start:=10, Length:=1).Font.ColorIndex = 3
    Range("I8").Value = CStr(1998 + InStr(1, "XY123456789ABCDEFGHJKLMNOPQRSTUVW", Mid(Range("B8").Value, 10, 1), vbBinaryCompare))
End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Solved
Extra condition in search VBA.
Replies
2
Views
155
pete4monc
P
R
  • Solved
Is it possible to have static timestamp each time you run macro a new one is added to the row?
Replies
6
Views
282
rebeila
R
M
  • Question
Add in VBA Code to check zip code against pre-determined list
Replies
0
Views
144
mikefisher
M
Chris_010101
  • Solved
Error 1004
Replies
3
Views
174
Domenic
D
E
  • Question
Auto close spreadsheet timer not working correctly
2
Replies
17
Views
764
eli_m
E

Forum statistics

Threads
1,214,429
Messages
6,119,433
Members
448,897
Latest member
ksjohnson1970

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