Run time error 13 issue

[ipbr21054]

Morning,
On my worksheet i use the following codes which,highlight the row that i am on,change the text to CAPITALS & also a button to insert a new row.
When i insert a new row i get a Run time error 13,type mismatch.
When i click on debug i see this line shown in yellow .Value = UCase(.Value)
Without the CAPITAL code in the sheet this above issue is gone.

Please could you advise how i get around this issue.

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 = "F"


'   *** Specify start row ***
    myStartRow = 4
    
'   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

I also use this code to change text to CAPITALS.

Private Sub Worksheet_Change(ByVal Target As Range)    With Target
        If Not .HasFormula Then
            Application.EnableEvents = False
            .Value = UCase(.Value)
            Application.EnableEvents = True
        End If
    End With
End Sub

There is also a new insert button.

Private Sub NewRowButton_Click()Sheets("SKP IMMO LIST").Range("A4").Select
ActiveCell.EntireRow.Insert Shift:=xlDown
Sheets("SKP IMMO LIST").Range("A4:F4").Select
Selection.Borders.Weight = xlThin
Sheets("SKP IMMO LIST").Range("A4").Select
End Sub

 

[ipbr21054]

I think a basic line of code inserted into the new line code would sort this.

 

[StephenCrump]

Your Worksheet_Change event code doesn't allow for the possibility of Target containing more than one cell. If it does, then testing Target.Value will return a type mismatch error.

Inserting a row will cause a problem, as will other actions such as copying/pasting multiple cells.

Your code needs to either:

- Test for Target.Count = 1, or

- Loop through every cell in Target

 

[ipbr21054]

Hi
Thanks for the reply.
Unfortunately that's well out of my field.

 

[StephenCrump]

This will capitalise values entered cell by cell, which I suspect will meet your needs:

Private Sub Worksheet_Change(ByVal Target As Range)
    
    With Target
        If [COLOR=#ff0000][B].Count = 1 And[/B][/COLOR] Not .HasFormula Then
            Application.EnableEvents = False
            .Value = UCase(.Value)
            Application.EnableEvents = True
        End If
    End With

End Sub

 

[ipbr21054]

Hey
Thanks very much for that.
This code would need to be put on every worksheet within my workbook for it to run OR can one code be put alt & f11 this workbook to then have it applied to all the worksheets ?
Saves copy/paste say 10 times ?

 

[StephenCrump]

Instead of using Worksheet_Change events in each worksheet module, you can use the Workbook_SheetChange event which sits in the ThisWorkbook module:

'In ThisWorkbook module
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    MsgBox "You changed range " & Target.Address & " in worksheet " & Sh.Name

End Sub

 

[ipbr21054]

StephenCrump,
Many thanks, i went with your post at #5 and works great.
I have noticed that on one worksheet there is already a Worksheet Change event and im not sure how to correctly add this following code into it so there is no conflict.

Private Sub Worksheet_Change(ByVal Target As Range)    With Target
        If .Count = 1 And Not .HasFormula Then
            Application.EnableEvents = False
            .Value = UCase(.Value)
            Application.EnableEvents = True
        End If
    End With
End Sub

Needs to be added into the code below.

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("C1:F12").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
    Range("A17").Select
    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
                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
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

 

[StephenCrump]

You could slot the first bit of code at the top of the second, but placement isn't critical.

I notice you've set Application.EnableEvents = False, to prevent recursive triggering of the Worksheet_Change event, but there's a few other places in Worksheet_Change making changes that you've missed.

You could also do similar in other Subs making changes to the worksheet, e.g. I assume Sub NewRowButton_Click is operating on this sheet?

 

[ipbr21054]

Hi,
This is the Newbie in me.
Yes NewRowButton_click is working fine.

In respect to the rest of what you wrote it went over my head.

All items in that code i supplied work how i need them to without any error or pop up message.
As i have put your edited code for CAPITALS on the other sheets i thought i would also put it on this one.

Im asking for a supplied code from you again please.