ipbr21054
Well-known Member
- Joined
- Nov 16, 2010
- Messages
- 5,832
- Office Version
- 2007
- Platform
- Windows
Hi,
A few months back i was looking at using a code but no browsing through the archives i dont find it,
We are looking at the 10th character in one cell then adding a corresponding value to another cell.
So my page operates like this.
I paste a value or letters & numbers into cell A13 & then this value is automatically transfered to cell A21
"This is where i would like the additional code to now be included"
Once the value enters cell A21 look at the 10th character and do the following.
If A then in cell D21 enter 2010
If B then in cell D21 enter 2011
If C then in cell D21 enter 2012
If D then in cell D21 enter 2013
Thats it,the list above is a short example but i can add the rest once i have the code.
Many thanks.
In the past ive been advised to supply the whole page code so below it is.
A few months back i was looking at using a code but no browsing through the archives i dont find it,
We are looking at the 10th character in one cell then adding a corresponding value to another cell.
So my page operates like this.
I paste a value or letters & numbers into cell A13 & then this value is automatically transfered to cell A21
"This is where i would like the additional code to now be included"
Once the value enters cell A21 look at the 10th character and do the following.
If A then in cell D21 enter 2010
If B then in cell D21 enter 2011
If C then in cell D21 enter 2012
If D then in cell D21 enter 2013
Thats it,the list above is a short example but i can add the rest once i have the code.
Many thanks.
In the past ive been advised to supply the whole page code so below it is.
Code:
Private Sub NewRowButton_Click()With Sheets("HONDA SHEET")
.Range("A21").EntireRow.Insert Shift:=xlDown
.Range("A21:G21").Borders.Weight = xlThin
.Range("G21").Value = Date
.Range("A13").Interior.ColorIndex = 2
Range("C1:F21").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
Range("A13").Interior.ColorIndex = 6
End With
End Sub
Private Sub CheckButton_Click()
HondaParts.Show
End Sub
Sub OpenFile()
Workbooks.Open Filename:="C:\LEADERBOARD\book.xls"
End Sub
Private Sub BalanceSoFar_Click()
Dim lngLastRow As Long
Dim lngSumValues As Double
With Sheets("DATABASE")
lngLastRow = .Cells(.Rows.Count, "O").End(xlUp).Row
lngSumValue = Application.WorksheetFunction.Sum(.Range("O5:O" & lngLastRow))
End With
MsgBox "Earnings To Date " & Format(lngSumValue, "£0.00")
End Sub
Private Sub OnlineEpc_Click()
ActiveWorkbook.FollowHyperlink Address:="https://honda-europe.epc-data.com/", NewWindow:=True
End Sub
Private Sub EpcLate_Click()
ActiveWorkbook.FollowHyperlink Address:="http://www.hondapartsdeals.com/honda_parts.php", NewWindow:=True
End Sub
Private Sub ComboBox1_Change()
End Sub
Private Sub EuropeEpc_Click()
ActiveWorkbook.FollowHyperlink Address:="https://honda-europe.epc-data.com/", NewWindow:=True
End Sub
Private Sub Hondasheet_bluecells_Click()
Range("C1:F17").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
Range("A13").Select
End Sub
Private Sub Hondasheet_leaderboard_Click()
Worksheets("HONDA SHEET").Range("C1:D17").Copy Worksheets("SOLD ITEMS").Range("C2:D19")
Worksheets("HONDA SHEET").Range("E1:F17").Copy Worksheets("SOLD ITEMS").Range("C19:D35")
ActiveWorkbook.Worksheets("SOLD ITEMS").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("SOLD ITEMS").Sort.SortFields.Add Key:=Range("D2"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortTextAsNumbers
With Worksheets("SOLD ITEMS").Sort
.SetRange Range("C2:D35")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
Range("A16").Select
.Apply
End With
Application.CutCopyMode = False
Call HONDA_SALES_TABLE
End Sub
Private Sub Hondasheet_zerocells_Click()
Dim warning
warning = MsgBox(Range("A3").Value & "Are You Sure You Wish To Zero All The Cells ?", vbQuestion + vbYesNo, "Warning This Will Delete The Cell Info")
If warning = vbNo Then Exit Sub
Range("D1", "D17") = "0"
Range("F1", "F17") = "0"
Range("C1:F17").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
Range("A13").Select
End Sub
Private Sub JapanEpc_Click()
ActiveWorkbook.FollowHyperlink Address:="https://honda.epc-data.com/", NewWindow:=True
End Sub
Private Sub LateEpc_Click()
ActiveWorkbook.FollowHyperlink Address:="http://www.hondapartsdeals.com/honda_parts.php", NewWindow:=True
End Sub
Private Sub PoundSign_Click()
Dim lngLastRow As Long
Dim lngSumValues As Double
With Sheets("DATABASE")
lngLastRow = .Cells(.Rows.Count, "O").End(xlUp).Row
lngSumValue = Application.WorksheetFunction.Sum(.Range("O5:O" & lngLastRow))
End With
MsgBox "Earnings To Date " & Format(lngSumValue, "£0.00")
End Sub
Private Sub TopOfPage_Click()
Range("A21").Select
End Sub
Private Sub VinToolButton_Click()
ActiveWorkbook.FollowHyperlink Address:="http://www.hondapartsdeals.com/honda_parts.php", NewWindow:=True
End Sub
Private Sub Worksheet_Activate()
Range("A13").Select
Range("A13").Font.Size = 18
Range("A13").BorderAround xlContinuous, xlThin
Range("A17").BorderAround xlContinuous, xlThin
ActiveWindow.ScrollRow = 14
Range("A17").Interior.ColorIndex = 2
Range("A17").Font.Size = 18
Range("A17").Name = "Calibri"
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Frng As Range
Set Frng = Range("F21", Range("F" & Rows.Count).End(xlUp))
If Target.Address(0, 0) = "A2" Then
With HondaSoldItems
.Caption = "HONDA SOLD ITEMS TABLE"
.txtQuantitySold.Text = Application.CountIf(Frng, Target.Value)
.txtSoldItems.Text = Target.Value
.CommandButton1.SetFocus
.Show
End With
End If
With ThisWorkbook.Sheets("HONDA SHEET")
If Not Intersect(Target, .Range("A13")) Is Nothing And .Range("A13") <> "" Then
If Len(.Range("A13").Value) <> 17 And Len(.Range("A13").Value) <> 11 Then
.Range("A13").Interior.ColorIndex = 3
MsgBox "Honda Japan Use 11 Character Vin Numbers." & vbNewLine & "" & vbNewLine & "Honda Europe Use 17 Character Vin Numbers." & vbNewLine & "" & vbNewLine & "Please Check & Try Again", vbCritical, "Chassis Number Wrong Character Count"
.Range("A13").ClearContents
.Range("A13").Interior.ColorIndex = 2
.Range("A13").Activate
Else
Application.EnableEvents = False
.Rows(21).Insert Shift:=xlDown
.Range("A21:G21").Borders.Weight = xlThin
.Range("G21").Value = Date
.Range("A21").Value = UCase(.Range("A13").Value)
.Range("B21").Select
.Range("A13").ClearContents
.Range("A21").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("F21")) 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 HLIK-1T 2B" Then Range("D9").Value = Range("D9").Value + 1
If Target.Value = "FLIP HLIK-1T 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("D14").Value = Range("D14").Value + 1
If Target.Value = "G8D-350H-A" Then Range("D15").Value = Range("D15").Value + 1
If Target.Value = "G8D-453H-A" Then Range("D16").Value = Range("D16").Value + 1
If Target.Value = "G8D-456H-A" Then Range("D17").Value = Range("D17").Value + 1
If Target.Value = "HONDA 001" Then Range("F1").Value = Range("F1").Value + 1
If Target.Value = "HONDA 022" Then Range("F2").Value = Range("F2").Value + 1
If Target.Value = "HONDA 023" Then Range("F3").Value = Range("F3").Value + 1
If Target.Value = "HONDA 024" Then Range("F4").Value = Range("F4").Value + 1
If Target.Value = "HONDA 036" Then Range("F5").Value = Range("F5").Value + 1
If Target.Value = "HONDA 042" Then Range("F6").Value = Range("F6").Value + 1
If Target.Value = "HON 58 ID 13" Then Range("F7").Value = Range("F7").Value + 1
If Target.Value = "HON 58 ID 48" Then Range("F8").Value = Range("F8").Value + 1
If Target.Value = "JAZZ HLIK-1T" Then Range("F9").Value = Range("F9").Value + 1
If Target.Value = "JAZZ ID 48" Then Range("F10").Value = Range("F10").Value + 1
If Target.Value = "JAZZ ID 8E" Then Range("F11").Value = Range("F11").Value + 1
If Target.Value = "KEY DIY NBXTT ID 47" Then Range("F12").Value = Range("F12").Value + 1
If Target.Value = "LEGEND ID 8E" Then Range("F13").Value = Range("F13").Value + 1
If Target.Value = "SILVER NRK ID 48" Then Range("F14").Value = Range("F14").Value + 1
If Target.Value = "SILVER NRK ID 8E" Then Range("F15").Value = Range("F15").Value + 1
If Target.Value = "72147-S2H-G01" Then Range("F16").Value = Range("F16").Value + 1
If Target.Value = "S2000 CAT 1" Then Range("F17").Value = Range("F17").Value + 1
End If
If Target.Address = "$F$21" Then
Call sheettolist
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 = 21
' 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