Edit to current working code is needed please

I

ipbr21054

Well-known Member
Joined
Nov 16, 2010
Messages
5,832
Office Version
  1. 2007
Platform
  1. Windows
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.

Code: 
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
 
Sort by date Sort by votes
Is this all on one line (sometimes the board strips out the first linefeed)?
Code: 
If Range("D17").Value = "" Then   MsgBox "YEAR NOT FOUND" & vbNewLine & "ENTERED VIN WILL BE DELETED"
If so it should be on 2 lines, as I showed.
If not can you please post your entire code?
 
Upvote 0

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.
Hi,
Yes i changed it from 1 line to 2 lines like shown.

Code supplied.

Code: 
Private Sub CommandButton1_Click()MsgBox "Entered value is " & Worksheets("POSTAGE").Range("B50").Value
End Sub


Private Sub NewRowButton_Click()
With Sheets("HONDA SHEET")
    .Range("A17").EntireRow.Insert Shift:=xlDown
    .Range("A17:G18").Borders.Weight = xlThin
    .Range("G17").Value = Date
    .Range("A13").Interior.ColorIndex = 2
     Range("C1:F12").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
    Range("A17").Select
    Range("A13").Interior.ColorIndex = 6
    End With
End Sub


Private Sub CheckButton_Click()
HondaParts.Show
End Sub


Private Sub VinToolButton_Click()
ActiveWorkbook.FollowHyperlink Address:="http://www.vindecoderz.com/EN/Honda", NewWindow:=True
End Sub


Private Sub Worksheet_Activate()
    Range("A13").Select
    ActiveWindow.ScrollRow = 14
End Sub




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
Dim a
a = Mid(Range("A17"), 10, 1)
If a Like "[1-9]" Then
  Range("D17").Value = "200" & a
ElseIf a Like "[A-Y]" Then
   Range("D17").Value = Choose(Asc(a) - 64, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, , 2018, 2019, 2020, 2021, 2022, , 2023, , 2024, 2025, 2026, , 2027, 2028, 2029, 2030)
End If


If Range("D17").Value = "" Then
   MsgBox "YEAR NOT FOUND" & vbNewLine & "ENTERED VIN WILL BE DELETED"
   Rows(17).EntireRow.Delete
   .Range("A13").Select
End If
Application.EnableEvents = True
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 UCase(Target.Value) = "M" Then Target.Value = "2021": x = 1
If UCase(Target.Value) = "N" Then Target.Value = "2022": x = 1
If UCase(Target.Value) = "P" Then Target.Value = "2023": x = 1
If UCase(Target.Value) = "R" Then Target.Value = "2024": x = 1
If UCase(Target.Value) = "S" Then Target.Value = "2025": x = 1
If UCase(Target.Value) = "T" Then Target.Value = "2026": x = 1
If UCase(Target.Value) = "V" Then Target.Value = "2027": x = 1
If UCase(Target.Value) = "W" Then Target.Value = "2028": x = 1
If UCase(Target.Value) = "X" Then Target.Value = "2029": x = 1
If UCase(Target.Value) = "Y" Then Target.Value = "2030": x = 1
If x < 1 Then MsgBox Target.Value & "  YEAR NOT FOUND": Target.Value = ""


End If
Application.EnableEvents = True
End Sub
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 = "G"


'   *** Specify start row ***
    myStartRow = 17
    
'   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.ScreenUpdating = True


End Sub
 
Upvote 0
You need another End If
Code: 
      Application.EnableEvents = True
      End If
 [COLOR=#ff0000]  End If
[/COLOR]

End With
 
Upvote 0
Glad to help & thanks for the feedback
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Solved
Working with multiple Target Ranges in Worksheet Code
Replies
3
Views
774
sspatriots
S
F
  • Question Question
VBA Code to record changes/logs modification needed?
Replies
0
Views
394
FGaxha
F
S
  • Question Question
Need code that adds multiple new rows to table to include a check box in column "L" for each new row
Replies
0
Views
544
sspatriots
S
M
  • Question Question
help is required with Code for the time between readings please
Replies
0
Views
422
microhunt
M
S
  • Question Question
Including Date Worked in Range D:D when Value in R:R Changes
Replies
0
Views
403
Sharonca
S

Forum statistics

Threads
1,224,822
Messages
6,181,164
Members
453,021
Latest member
Justyna P

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