CODEWITHSUNDEEP
excelvba
Felipe
Felipe

Reputation: 59

Error when select multiple cells and press delete/backspace

I have the following code. It does some stuff when specifically [G,g,Y,y,R,r] are pressed and there is an error handling in case other keys are pressed as well. This works fine! However, when multiple cells in column 11 are selected and delete/backspace is pressed I get "Run-time error '13': Type mismatch".

Private Sub Worksheet_Change(ByVal Target As Range)

Dim TestCell
Dim RE As Object
Dim REMatches As Object
Dim Cell1_1 As String
Dim Today As String
Dim Cell As String

ThisRow = Target.Row

'Action happens when typing [G,g,Y,y,R,r]

If Target.Column = 11 Then

Set RE = CreateObject("vbscript.regexp")

With RE
    .MultiLine = False
    .Global = False
    .IgnoreCase = True
    .Pattern = "[G,g,Y,y,R,r]"
End With

For Each TestCell In Target.Cells

Set REMatches = RE.Execute(TestCell.Value)

If REMatches.Count > 0 And Len(Target.Value) = 1 Then
    If Len(Cells(1, 1).Value) = 1 Then
        Today = Now()
        Cell1_1 = Sheets("Input").Cells(1, 1).Value
        Range("L" & ThisRow) = Cell1_1 + ": " + Format(Today, "ddmmmyy")
    End If

'Avoid typing another thing

ElseIf Target.Value <> vbNullString Then
     Row = Target.Row
     Cells(Row, 11).Value = vbNullString
     MsgBox "Please, type only:" & vbNewLine & vbNewLine & "G for Green" & vbNewLine & "Y for Yellow" & vbNewLine & "R for Red"

End If

Next

End If

End Sub

The error occurs at this line in the code.

If REMatches.Count > 0 And Len(Target.Value) = 1 Then

Upvotes: 1

Views: 339

Answers (1)

MatthewD
MatthewD

Reputation: 6761

If there is no lost functionality you can enclose that code in some error handling.

Private Sub Worksheet_Change(ByVal Target As Range)

Dim TestCell
Dim RE As Object
Dim REMatches As Object
Dim Cell1_1 As String
Dim Today As String
Dim Cell As String

ThisRow = Target.Row

'Action happens when typing [G,g,Y,y,R,r]

If Target.Column = 11 Then

Set RE = CreateObject("vbscript.regexp")

With RE
.MultiLine = False
.Global = False
.IgnoreCase = True
.Pattern = "[G,g,Y,y,R,r]"
End With

For Each TestCell In Target.Cells

Set REMatches = RE.Execute(TestCell.Value)

On Error Goto Skip    '************Error Handle*************
If REMatches.Count > 0 And Len(Target.Value) = 1 Then
    If Len(Cells(1, 1).Value) = 1 Then
        Today = Now()
        Cell1_1 = Sheets("Input").Cells(1, 1).Value
        Range("L" & ThisRow) = Cell1_1 + ": " + Format(Today, "ddmmmyy")
    End If

'Avoid typing another thing

ElseIf Target.Value <> vbNullString Then
     Row = Target.Row
     Cells(Row, 11).Value = vbNullString
     MsgBox "Please, type only:" & vbNewLine & vbNewLine & "G for Green" &     vbNewLine & "Y for Yellow" & vbNewLine & "R for Red"

End If

Skip:            '************Error Handle*************
On Error goto 0  '************Error Handle*************

Next

End If

End Sub

Or if the code still needs to execute

Private Sub Worksheet_Change(ByVal Target As Range)

Dim TestCell
Dim RE As Object
Dim REMatches As Object
Dim Cell1_1 As String
Dim Today As String
Dim Cell As String

ThisRow = Target.Row

'Action happens when typing [G,g,Y,y,R,r]

If Target.Column = 11 Then

Set RE = CreateObject("vbscript.regexp")

With RE
.MultiLine = False
.Global = False
.IgnoreCase = True
.Pattern = "[G,g,Y,y,R,r]"
End With

For Each TestCell In Target.Cells

Set REMatches = RE.Execute(TestCell.Value)

On Error Resume Next    '************Error Handle*************
If REMatches.Count > 0 And Len(Target.Value) = 1 Then
    If Len(Cells(1, 1).Value) = 1 Then
        Today = Now()
        Cell1_1 = Sheets("Input").Cells(1, 1).Value
        Range("L" & ThisRow) = Cell1_1 + ": " + Format(Today, "ddmmmyy")
    End If

'Avoid typing another thing

ElseIf Target.Value <> vbNullString Then
     Row = Target.Row
     Cells(Row, 11).Value = vbNullString
     MsgBox "Please, type only:" & vbNewLine & vbNewLine & "G for Green" &     vbNewLine & "Y for Yellow" & vbNewLine & "R for Red"

End If

On Error goto 0  '************Error Handle*************

Next

End If

End Sub

Upvotes: 1

Related Questions