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
What you've done is right as long as you have left the "blank" between 2017 & 2018 like
Code: 
 2017, , 2018
 
Upvote 0

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Hmmm,
Well i assumed the , , had to be moved to the end as it was at the end of this code but obviously not & dont understand why it stays in the middle ?

I have the following in use

Code: 
Dim aa = Mid(Range("A17"), 10, 1)
If a Like "[1-9]" Then
  Range("D17").Value = "200" & a
ElseIf a Like "[A-S]" Then
Range("D17").Value = Choose(Asc(a) - 64, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, , 2018, 2019, 2020, 2021, 2022, 2023, 2024, 2025)
End If
Application.EnableEvents = True
End If

I have just realised that not only is there no I year date but also there is no O Q U date either,sorry for being a dumb wit.
I cant cope at the moment so tomorrow i will follow this up with a letter / date range.

Sorry but cant work at the moment.
 
Upvote 0
Sorry but cant work at the moment.
Click to expand...
Not a problem. Whenever is fine :)

The reason that you are not getting a date for I is the "blank" between 2017 & 2018, but you should be getting years for O,Q & R.
The letters need to be in UpperCase, but that shouldn't be a problem as your existing code is converting to Ucase.
 
Upvote 0
OK
Thanks for explaining that.
I have now got the code below which works well & correct apart from the additional piece i added where should i enter a code which has say Q then as opposed to continuing with the code being copied from cell A13 into cell A17 & then cell D17 will be blank as no date year i think at this point i need to see a message box to advise no year date etc.
Pressing OK on message box would then clear the cell A13

Code: 
Dim aa = 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)
Then Range("D17").Value = ""
Then MsgBox "YEAR NOT FOUND"


End If
 
Upvote 0
Like
Code: 
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"
 
Upvote 0
So the code i have now as shown below should now do this for me,

Pasting a code into cell A13 using say the letter Q,i would see the message box advising me of the date error.
The copied code would still continue from A13 to A17 but upon pressing the OK on msgBox row 17 would now be deleted and focus set back on cell A13,Or have i taken the wrong approach to this ?


Code: 
Dim aa = 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"
Rows(17).EntireRow.Delete
.Range("A13").Select
End If
Application.EnableEvents = True
End If


End With
 
Upvote 0
Morning,
The code below is currently in use and works well apart from one thing.

It shows the msgbox if the year date is not recognised,i press ok to this & row 17 is deleted & focus is set to cell A13.
This is spot on.

My problem that i overlooked is when i paste a known value,no message box is shown which is correct BUT row 17 still gets deleted.

The edit i need advice on is do not delete row 17 if a valid year date is entered & to only delete row 17 if msgbox is shown etc.



Code: 
Dim aa = 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

Many thanks
 
Upvote 0
It needs to be like
Code: 
If Range("D17").Value = "" Then
   MsgBox "YEAR NOT FOUND" & vbNewLine & "ENTERED VIN WILL BE DELETED"
   Rows(17).EntireRow.Delete
   .Range("A13").Select
End If
 
Upvote 0
Hi,

I have changed the following
FROM
Code: 
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

TO
Code: 
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

But that now gives me Compile error End With without With
 
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,165
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