Strange problem when executing Worksheet Change code
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("D2:D16")) 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
--
HTH,
Barb Reinhardt
"JDaywalt" wrote:
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
D2:D16) 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
|