Strange problem when executing Worksheet Change code

[JDaywalt]

Below is an adaptation of code that was provided by Dave Peterson as a way to
automatically change sheet tab names based upon manual entries made on a
"Menu" tab. The code executes perfectly---that is not the issue. The
problem is that after you type the description (in any cell within range
D216) and hit <ENTER>, the cursor seems to disappear. When you look up in
the cell reference box (the one that shows which cell is currently active),
it shows the correct reference. (For example if I made my entry in cell D2
and hit ENTER, the reference shows D3). However, there is no "outline"
around D3. Even more confusing, if I then click in a different cell (i.e.
B1), I get an outline around B1 -- PLUS the outline then magically appears
around D3 as if I had done a CTRL-click to pick multiple cells. Any ideas
how to fix? Interestingly, if I click off the Menu tab, then go back,
everything looks as it should. Here is the code on my Menu worksheet:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Excel.Range)

Const sERROR As String = "Invalid worksheet name in cell "

Dim sSheetName As String
Dim mySheet As Object

With Target

'only one cell at a time
If .Cells.Count > 1 Then Exit Sub

Select Case Target.Address(0, 0)
Case Is = "D2": Set mySheet = Sheet3
Case Is = "D3": Set mySheet = Sheet4
Case Is = "D4": Set mySheet = Sheet5
Case Is = "D5": Set mySheet = Sheet6
Case Is = "D6": Set mySheet = Sheet7
Case Is = "D7": Set mySheet = Sheet8
Case Is = "D8": Set mySheet = Sheet9
Case Is = "D9": Set mySheet = Sheet10
Case Is = "D10": Set mySheet = Sheet11
Case Is = "D11": Set mySheet = Sheet12
Case Is = "D12": Set mySheet = Sheet13
Case Is = "D13": Set mySheet = Sheet14
Case Is = "D14": Set mySheet = Sheet15
Case Is = "D15": Set mySheet = Sheet16
Case Is = "D16": Set mySheet = Sheet17

Case Else
Exit Sub
End Select

sSheetName = .Text

If Not sSheetName = "" Then
On Error Resume Next
mySheet.Name = sSheetName
If Err.Number <> 0 Then
MsgBox sERROR & .Address(0, 0)
End If
On Error GoTo 0
End If
End With
End Sub

 

[JLGWhiz]

Couldn't duplicate the problem. Cursor remained viewable.

 

[Barb Reinhardt]

I get an error if one of the sheets doesn't exist (Sheet4, Sheet5, Sheet6).

I did some tweaking, but can't finish. Maybe this will help you.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Excel.Range)

Const sERROR As String = "Invalid worksheet name in cell "

Dim sSheetName As String
Dim mySheet As Object

With Target

'only one cell at a time
If .Cells.Count > 1 Then Exit Sub

If Intersect(Target, Range("D216")) Is Nothing Then Exit Sub
On Error Resume Next
Set mySheet = Nothing

Select Case Target.Address(0, 0)
Case Is = "D2": Set mySheet = FindSheet(Target, "Sheet3")
Case Is = "D3": Set mySheet = FindSheet(Target, "Sheet4")
Case Is = "D4": Set mySheet = FindSheet(Target, "Sheet5")
Case Is = "D5": Set mySheet = FindSheet(Target, "Sheet6")
Case Is = "D6": Set mySheet = FindSheet(Target, "Sheet7")
Case Is = "D7": Set mySheet = FindSheet(Target, "Sheet8")
Case Is = "D8": Set mySheet = FindSheet(Target, "Sheet9")
Case Is = "D9": Set mySheet = FindSheet(Target, "Sheet10")
Case Is = "D10": Set mySheet = FindSheet(Target, "Sheet11")
Case Is = "D11": Set mySheet = FindSheet(Target, "Sheet12")
Case Is = "D12": Set mySheet = FindSheet(Target, "Sheet13")
Case Is = "D13": Set mySheet = FindSheet(Target, "Sheet14")
Case Is = "D14": Set mySheet = FindSheet(Target, "Sheet15")
Case Is = "D15": Set mySheet = FindSheet(Target, "Sheet16")
Case Is = "D16": Set mySheet = FindSheet(Target, "Sheet17")

Case Else
Exit Sub
End Select
On Error GoTo 0

sSheetName = .Text
If Not mySheet Is Nothing Then

'What are you doing if the sheet isn't selected?

End If

End


If Not sSheetName = "" Then
On Error Resume Next
mySheet.Name = sSheetName
If Err.Number <> 0 Then
MsgBox sERROR & .Address(0, 0)
End If
On Error GoTo 0
End If
End With
End Sub

Function FindSheet(Target As Range, SheetCodeName As String) As Worksheet
Dim WB As Workbook
Dim WS As Worksheet

Set FindSheet = Nothing
Set WB = Target.Parent.Parent

For Each WS In WB.Worksheets
If WS.CodeName = SheetCodeName Then
Set FindSheet = WS
Exit For
End If
Next WS

If FindSheet Is Nothing Then
MsgBox ("Worksheet " & SheetCodeName & " was not found.")
End If
End Function