If & Then code advice

I

ipbr21054

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

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
 

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.
Sort by date Sort by votes
Re: If & Then code advice please

Hi ipbr21054,

Do you need a code solution? If you put the text A to D in cells A2:A5 with the years in cells B2:B5 in say Sheet1 you could use this formula in cell D21:

=VLOOKUP(MID(A21,10,1),Sheet1!A:B,2,FALSE)

That way you can just keep adding categories and years as required.

HTH

Robert
 
Last edited:
Upvote 0
Re: If & Then code advice please

Hi,
My sheet is laid out so unable to move data into different cells,sorry
 
Upvote 0
Re: If & Then code advice please

Not sure what you mean :confused:
You can have the lookup on any tab in the workbook I only said Sheet1 as an example. This won’t change the layout of the sheet you want the result in cell D21?
 
Upvote 0
Re: If & Then code advice please

Hi,
Thanks for the reply but i would like to do this using VBA
 
Upvote 0
Re: If & Then code advice please

Try this worksheet_event macro on the sheet in question (i.e. where you want the result in cell D21):

Code: 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Address = "$A$21" Then
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With
        Range("D21").Value = Evaluate("IFERROR(VLOOKUP(MID(A21,10,1),{""A"",2010;""B"",2011;""C"",2012;""D"",2013},2,FALSE),"""")")
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
    End If

End Sub

Just add to the VLOOKUP formula whenever you need to add another category.

Regards,

Robert
 
Upvote 0
Re: If & Then code advice please

Hi,
Im having difficulty trying to add the advised code into what i have at present.

Code: 
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
 
Upvote 0
Re: If & Then code advice please

Gee, that's a lot of code for a worksheet_change event macro.

Without your workbook I'm having all sorts of issues trying to replicate your code to work so all I can suggest is to put my code at the very end of your existing code and try that. If it fails try stepping through the code and see what the issue is, though by itself I have tested my code and it works fine.
 
Last edited:
Upvote 0
Re: If & Then code advice please

Put this wherever required

Code: 
Select Case Mid(Range("A13").Value, 10, 1)
    Case Is = "A"
        Range("D21").Value = "2010"
    Case Is = "B"
        Range("D21").Value = "2011"
    Case Is = "C"
        Range("D21").Value = "2012"
    Case Is = "D"
        Range("D21").Value = "2013"
End Select
 
Upvote 0
Re: If & Then code advice please

hi,
I put the above code in post #9 at the end of my page code.
I run my test but nothing was entered into cell D21.
I also didnt get any kind of error message either.

Did i place it in the wrong place ?

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


Select Case Mid(Range("A13").Value, 10, 1)
    Case Is = "A"
        Range("D21").Value = "2010"
    Case Is = "B"
        Range("D21").Value = "2011"
    Case Is = "C"
        Range("D21").Value = "2012"
    Case Is = "D"
        Range("D21").Value = "2013"
End Select


End Sub
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

F
  • Solved
Populate a range by clicking another cell
Replies
3
Views
157
rollis13
rollis13
F
  • Question
VBA Code to record changes/logs modification needed?
Replies
0
Views
62
FGaxha
F
S
  • Solved
Working with multiple Target Ranges in Worksheet Code
Replies
3
Views
374
sspatriots
S
S
  • Question
Add Deselect VBA Coding for Multiselect Dropdown
Replies
1
Views
1K
John_w
J
V
  • Solved
Help in revising VBA code
Replies
3
Views
174
kevin9999
K

Forum statistics

Threads
1,214,959
Messages
6,122,476
Members
449,087
Latest member
RExcelSearch

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