Edit to current working code is needed please

[ipbr21054]

Morning all,
Can you advise how i would go about the following request please.
Each day i would enter data into my worksheet.
The cells in question are always the same.
The cell the data is entered into is A17
As i leave this cell in question i would like some code to look at the 10th character & then apply the value from our look up database & then enter it to the cell D17

I do have something in use at present but its no ideal so maybe it can be edited for my request to work ?
I have supplied the code below & the part in question is towards the end.
Many Thanks.

Private Sub Worksheet_Change(ByVal Target As Range)With ThisWorkbook.Sheets("HONDA SHEET")
If Not Intersect(Target, .Range("A13")) Is Nothing And .Range("A13") <> "" Then
If Len(.Range("A13").Value) <> 17 Then
               .Range("A13").Interior.ColorIndex = 3
               MsgBox ("Honda Chassis Number Must Be 17 Characters, Please Try Again")
                .Range("A13").ClearContents
                .Range("A13").Interior.ColorIndex = 2
                .Range("A13").Activate
Else
                Application.EnableEvents = False
                .Rows(17).Insert Shift:=xlDown
                .Range("A17:G17").Borders.Weight = xlThin
                .Range("G17").Value = Date
                .Range("A17").Value = UCase(.Range("A13").Value)
                .Range("B17").Select
                .Range("A13").ClearContents
                .Range("A17").Characters(Start:=10, Length:=1).Font.ColorIndex = 3
                Application.EnableEvents = True
End If
End If
End With


Target.Interior.ColorIndex = 6
If Not Intersect(Target, Range("F17")) Is Nothing Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
If Target.Value = "ACCORD ID 48" Then Range("D1").Value = Range("D1").Value + 1
If Target.Value = "ACCORD ID 8E" Then Range("D2").Value = Range("D2").Value + 1
If Target.Value = "BLACK NRK ID 46" Then Range("D3").Value = Range("D3").Value + 1
If Target.Value = "BLACK NRK ID 48" Then Range("D4").Value = Range("D4").Value + 1
If Target.Value = "BLACK NRK ID 8E" Then Range("D5").Value = Range("D5").Value + 1
If Target.Value = "CIVIC CE0523" Then Range("D6").Value = Range("D6").Value + 1
If Target.Value = "CRV HLIK-1T" Then Range("D7").Value = Range("D7").Value + 1
If Target.Value = "CRV ID 48" Then Range("D8").Value = Range("D8").Value + 1
If Target.Value = "FLIP REMOTE 2B" Then Range("D9").Value = Range("D9").Value + 1
If Target.Value = "FLIP REMOTE 3B" Then Range("D10").Value = Range("D10").Value + 1
If Target.Value = "FRV ID 48" Then Range("D11").Value = Range("D11").Value + 1
If Target.Value = "FRV ID 8E" Then Range("D12").Value = Range("D12").Value + 1
If Target.Value = "G8D-345H-A" Then Range("D13").Value = Range("D13").Value + 1
If Target.Value = "G8D-348H-A" Then Range("F1").Value = Range("F1").Value + 1
If Target.Value = "G8D-350H-A" Then Range("F2").Value = Range("F2").Value + 1
If Target.Value = "G8D-453H-A" Then Range("F3").Value = Range("F3").Value + 1
If Target.Value = "G8D-456H-A" Then Range("F4").Value = Range("F4").Value + 1
If Target.Value = "HON 58 ID 13" Then Range("F5").Value = Range("F5").Value + 1
If Target.Value = "HON 58 ID 48" Then Range("F6").Value = Range("F6").Value + 1
If Target.Value = "JAZZ HLIK-1T" Then Range("F7").Value = Range("F7").Value + 1
If Target.Value = "JAZZ ID 48" Then Range("F8").Value = Range("F8").Value + 1
If Target.Value = "JAZZ ID 8E" Then Range("F9").Value = Range("F9").Value + 1
If Target.Value = "LEGEND ID 8E" Then Range("F10").Value = Range("F10").Value + 1
If Target.Value = "SILVER NRK ID 48" Then Range("F11").Value = Range("F11").Value + 1
If Target.Value = "SILVER NRK ID 8E" Then Range("F12").Value = Range("F12").Value + 1
If Target.Value = "72147-S2H-G01" Then Range("F13").Value = Range("F13").Value + 1
End If
    If Target.Address = "$F$17" Then
        Call sheettolist
    End If


If Not Intersect(Target, Range("B13")) Is Nothing Then
Dim x As Long
x = 0
Application.EnableEvents = False
If UCase(Target.Value) = "A" Then Target.Value = "2010": x = 1
If UCase(Target.Value) = "B" Then Target.Value = "2011": x = 1
If UCase(Target.Value) = "C" Then Target.Value = "2012": x = 1
If UCase(Target.Value) = "D" Then Target.Value = "2013": x = 1
If UCase(Target.Value) = "E" Then Target.Value = "2014": x = 1
If UCase(Target.Value) = "F" Then Target.Value = "2015": x = 1
If UCase(Target.Value) = "G" Then Target.Value = "2016": x = 1
If UCase(Target.Value) = "H" Then Target.Value = "2017": x = 1
If UCase(Target.Value) = "J" Then Target.Value = "2018": x = 1
If UCase(Target.Value) = "K" Then Target.Value = "2019": x = 1
If UCase(Target.Value) = "L" Then Target.Value = "2020": x = 1
If x < 1 Then MsgBox Target.Value & "  YEAR NOT FOUND": Target.Value = ""
End If
Application.EnableEvents = True
End Sub

 

[dmt32]

Hi,
In my advancing years I sometimes have difficulty interpreting some OPs requests & yours for me at least, is one of them.

You say

The cell the data is entered into is A17

code you posted Range A17 is made Equal to value entered in Range A13 so user not directly entering data in that Range – is that correct?

You then go on to say

As I leave this cell in question i would like some code to look at the 10th character & then apply the value from our look up database & then enter it to the cell D17

you have not supplied any details of your database for the lookup?

And finally you say

I have supplied the code below & the part in question is towards the end.

Which part are you referring to? It would help if you had highlighted the part of your code you want to amend.

It may help you if you break you long code in to its component parts which you should find easier to amend to your specific need.
Following not fully tested & is just a vain attempt to shorten all those IF statements but hopefully, will give you something you can develop further & maybe another here can offer some guidance.

 Option Base 1
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo exitsub
    Application.EnableEvents = False
    If Len(Target.Value) > 0 Then
        If Not Intersect(Target, Me.Range("A13")) Is Nothing Then RangeA13 Target
        If Not Intersect(Target, Me.Range("B13")) Is Nothing Then RangeB13 Target
        If Not Intersect(Target, Me.Range("F17")) Is Nothing Then RangeF17 Target
    End If
exitsub:
    Application.EnableEvents = True
End Sub


Sub RangeA13(ByVal Target As Range)
    If Len(Target.Value) <> 17 Then
        With Target
            .Interior.ColorIndex = 3
            .ClearContents
            .Interior.ColorIndex = 2
            .Activate
        End With
        MsgBox "Honda Chassis Number Must Be 17 Characters, Please Try Again", 48, "Invalid Entry"
    Else
        With Target.Parent
            .Rows(17).Insert Shift:=xlDown
            .Range("A17:G17").Borders.Weight = xlThin
            .Range("G17").Value = Date
            .Range("A17").Value = UCase(.Range("A13").Value)
            .Range("B17").Select
            .Range("A13").ClearContents
            .Range("A17").Characters(Start:=10, Length:=1).Font.ColorIndex = 3
        End With
    End If
End Sub


Sub RangeB13(ByVal Target As Range)
    If UCase(Target.Value) Like "[A-L]" Then
        Target.Value = 2010 + (Asc(UCase(Target.Value))) - 65
    Else
        MsgBox Target.Value & "  YEAR NOT FOUND": Target.Value = ""
    End If
End Sub


Sub RangeF17(ByVal Target As Range)
    Dim m As Variant, arr As Variant
    arr = Array("ACCORD ID 48", "ACCORD ID 8E", "BLACK NRK ID 46", "BLACK NRK ID 48", _
                "BLACK NRK ID 8E", "CIVIC CE0523", "CRV HLIK-1T", "CRV ID 48", _
                "FLIP REMOTE 2B", "FLIP REMOTE 3B", "FRV ID 48", "FRV ID 8E", _
                "G8D-345H-A", "G8D-348H-A", "G8D-350H-A", "G8D-453H-A", _
                "G8D-456H-A", "HON 58 ID 13", "HON 58 ID 48", "JAZZ HLIK-1T", _
                "JAZZ ID 48", "JAZZ ID 8E", "LEGEND ID 8E", "SILVER NRK ID 48", _
                "SILVER NRK ID 8E", "72147-S2H-G01")
    m = Application.Match(Target.Value, arr, False)
    If Not IsError(m) Then
        m = CLng(m)
        Cells(IIf(m < 14, m, m - 13), IIf(m < 14, 4, 6)).Value = _
        Cells(IIf(m < 14, m, m - 13), IIf(m < 14, 4, 6)).Value + 1
    Call sheettolist
    End If
     
End Sub

Hope Helpful

Dave

 

[ipbr21054]

Morning,
Thanks for the reply & sorry but im no good at explaining things as i have learning difficulties.

I have tried the code above but a few of my buttons kick up an error message,i have decided not to continue trying to fix them but concentrate on my original plan so i will try and explain better.

I come to this worksheet & paste a 17 digit value into cell A13.

A code then puts this value into cell A17
At this point all is fine & here is where i need the new edit.

In cell A17 the 10th character is shown in red & refers to a year.
So depending on what the 10th character is then its related year is converted to a date & pasted into cell D17

The code that is missing is the part that converts the 10th character from cell A17 & the pastes it into cell D17

I would need to make a database list like so

1 = 2001
2 = 2002
3 = 2003
4 = 2004
5 = 2005
6 = 2006
7 = 2007
8 = 2008
9 = 2009
A = 2010
B = 2011
C = 2012
D = 2013
E = 2014
F = 2015
G = 2016
H = 2017
J = 2018
Once sorted the process should work like this.

17 digit character is pasted into cell A13 but then pasted to cell A17.
New code now looks at the 10th character & say in this case its the letter B
So the new code looks at B in my database & sees the date 2011
The code then enters 2011 into cell D17

Thats it.
Hope this helps

Maybe a look up code but im not sure on how to make the code to look at the 10th character.

 

[ipbr21054]

Not sure if this is the correct way to go about it but
Should i continue to make a VLOOKUP list in the same worksheet then you could advise a code for when the cell A17 has a value it will then use my VLOOKUP table & return the date for cell D17 ?

 

[Fluff]

How about

Dim a
a = Mid(Range("A17"), 10, 1)
If a Like "[1-9]" Then
  Range("D17").Value = "200" & a
ElseIf a Like "[A-J]" Then
   Range("D17").Value = Choose(Asc(a) - 64, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, , 2018)
End If

 

[ipbr21054]

Hi
How or where do I apply/add this ?

Thanks.

 

[Fluff]

Add it just after you highlight the 10th character

 

[ipbr21054]

Perfect,
Works a dream & just what i was looking for.

Because I isnt a year date how would we allow for a break in the letters but not the year date ?
I mean like the following,

F = 2015
G = 2016
H = 2017

Now to allow for the missing I so it would continue as so,

J = 2018
K = 2019
L = 2020

If we follow the code at present then I would = 2018 hence the request.

Many thanks for your time in helping me with this.

 

[Fluff]

H should give 2017 & J should give 2018. I shouldn't give you a value

 

[ipbr21054]

Hi,
My mistake then sorry,i was trying to extend the range so,

[A J] Would now be [A-S]

I then also added the later years like 2019 2020 2121 up to 2025
This is when i noticed that I was given me a year.