Sorry to be so unclear in my last post. This is what I was talking
about. It works absolute perfectly its just alot of code
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Const sTOURCELL1 As String = "A3"
Const sTOURCELL2 As String = "A4"
Const sTOURCELL3 As String = "A5"
Const sTOURCELL4 As String = "A6"
Const sTOURCELL5 As String = "A7"
Const sTOURCELL6 As String = "A8"
Const sTOURCELL7 As String = "A9"
Const sTOURCELL8 As String = "A10"
Const sTOURCELL9 As String = "A11"
Const sTOURCELL10 As String = "A12"
Const sTOURCELL11 As String = "A13"
Const sTOURCELL12 As String = "A14"
Const sTOURCELL13 As String = "A15"
Const sTOURCELL14 As String = "A16"
Const sTOURCELL15 As String = "A17"
Const sTOURCELL16 As String = "A18"
Const sPLAYERNAMECELL1 As String = "A22"
Const sPLAYERNAMECELL2 As String = "A23"
Const sPLAYERNAMECELL3 As String = "A24"
Const sPLAYERNAMECELL4 As String = "A25"
Const sPLAYERNAMECELL5 As String = "A26"
Const sPLAYERNAMECELL6 As String = "A27"
Const sPLAYERNAMECELL7 As String = "A28"
Const sPLAYERNAMECELL8 As String = "A29"
Const sPLAYERNAMECELL9 As String = "A30"
Const sPLAYERNAMECELL10 As String = "A31"
Const sPLAYERNAMECELL11 As String = "A32"
Const sPLAYERNAMECELL12 As String = "A33"
Const sPLAYERNAMECELL13 As String = "A34"
Const sPLAYERNAMECELL14 As String = "A35"
Const sPLAYERNAMECELL15 As String = "A36"
Const sPLAYERNUMBERCELL1 As String = "B22"
Const sPLAYERNUMBERCELL2 As String = "B23"
Const sPLAYERNUMBERCELL3 As String = "B24"
Const sPLAYERNUMBERCELL4 As String = "B25"
Const sPLAYERNUMBERCELL5 As String = "B26"
Const sPLAYERNUMBERCELL6 As String = "B27"
Const sPLAYERNUMBERCELL7 As String = "B28"
Const sPLAYERNUMBERCELL8 As String = "B29"
Const sPLAYERNUMBERCELL9 As String = "B30"
Const sPLAYERNUMBERCELL10 As String = "B31"
Const sPLAYERNUMBERCELL11 As String = "B32"
Const sPLAYERNUMBERCELL12 As String = "B33"
Const sPLAYERNUMBERCELL13 As String = "B34"
Const sPLAYERNUMBERCELL14 As String = "B35"
Const sPLAYERNUMBERCELL15 As String = "B36"
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 Not (Intersect(.Cells, Me.Range(sTOURCELL1)) Is Nothing)
Then
'in A3
Set mySheet = Sheet2
ElseIf Not (Intersect(.Cells, Me.Range(sTOURCELL2)) Is
Nothing) Then
'in A4
Set mySheet = Sheet3
ElseIf Not (Intersect(.Cells, Me.Range(sTOURCELL3)) Is
Nothing) Then
'in A5
Set mySheet = Sheet4
ElseIf Not (Intersect(.Cells, Me.Range(sTOURCELL4)) Is
Nothing) Then
'in A6
Set mySheet = Sheet5
ElseIf Not (Intersect(.Cells, Me.Range(sTOURCELL5)) Is
Nothing) Then
'in A7
Set mySheet = Sheet6
ElseIf Not (Intersect(.Cells, Me.Range(sTOURCELL6)) Is
Nothing) Then
'in A8
Set mySheet = Sheet7
ElseIf Not (Intersect(.Cells, Me.Range(sTOURCELL7)) Is
Nothing) Then
'in A9
Set mySheet = Sheet8
ElseIf Not (Intersect(.Cells, Me.Range(sTOURCELL8)) Is
Nothing) Then
'in A10
Set mySheet = Sheet9
ElseIf Not (Intersect(.Cells, Me.Range(sTOURCELL9)) Is
Nothing) Then
'in A11
Set mySheet = Sheet10
ElseIf Not (Intersect(.Cells, Me.Range(sTOURCELL10)) Is
Nothing) Then
'in A12
Set mySheet = Sheet11
ElseIf Not (Intersect(.Cells, Me.Range(sTOURCELL11)) Is
Nothing) Then
'in A13
Set mySheet = Sheet12
ElseIf Not (Intersect(.Cells, Me.Range(sTOURCELL12)) Is
Nothing) Then
'in A14
Set mySheet = Sheet13
ElseIf Not (Intersect(.Cells, Me.Range(sTOURCELL13)) Is
Nothing) Then
'in A15
Set mySheet = Sheet14
ElseIf Not (Intersect(.Cells, Me.Range(sTOURCELL14)) Is
Nothing) Then
'in A16
Set mySheet = Sheet35
ElseIf Not (Intersect(.Cells, Me.Range(sTOURCELL15)) Is
Nothing) Then
'in A17
Set mySheet = Sheet36
ElseIf Not (Intersect(.Cells, Me.Range(sTOURCELL16)) Is
Nothing) Then
'in A18
Set mySheet = Sheet37
ElseIf Not (Intersect(.Cells, Me.Range(sPLAYERCELL1)) Is
Nothing) Then
'in A22
Set mySheet = Sheet15
ElseIf Not (Intersect(.Cells, Me.Range(sPLAYERCELL2)) Is
Nothing) Then
'in A23
Set mySheet = Sheet16
ElseIf Not (Intersect(.Cells, Me.Range(sPLAYERCELL3)) Is
Nothing) Then
'in A24
Set mySheet = Sheet17
ElseIf Not (Intersect(.Cells, Me.Range(sPLAYERCELL4)) Is
Nothing) Then
'in A25
Set mySheet = Sheet18
ElseIf Not (Intersect(.Cells, Me.Range(sPLAYERCELL5)) Is
Nothing) Then
'in A26
Set mySheet = Sheet19
ElseIf Not (Intersect(.Cells, Me.Range(sPLAYERCELL6)) Is
Nothing) Then
'in A27
Set mySheet = Sheet20
ElseIf Not (Intersect(.Cells, Me.Range(sPLAYERCELL7)) Is
Nothing) Then
'in A28
Set mySheet = Sheet21
ElseIf Not (Intersect(.Cells, Me.Range(sPLAYERCELL8)) Is
Nothing) Then
'in A29
Set mySheet = Sheet22
ElseIf Not (Intersect(.Cells, Me.Range(sPLAYERCELL9)) Is
Nothing) Then
'in A30
Set mySheet = Sheet23
ElseIf Not (Intersect(.Cells, Me.Range(sPLAYERCELL10)) Is
Nothing) Then
'in A31
Set mySheet = Sheet24
ElseIf Not (Intersect(.Cells, Me.Range(sPLAYERCELL11)) Is
Nothing) Then
'in A32
Set mySheet = Sheet25
ElseIf Not (Intersect(.Cells, Me.Range(sPLAYERCELL12)) Is
Nothing) Then
'in A33
Set mySheet = Sheet38
ElseIf Not (Intersect(.Cells, Me.Range(sPLAYERCELL13)) Is
Nothing) Then
'in A34
Set mySheet = Sheet39
ElseIf Not (Intersect(.Cells, Me.Range(sPLAYERCELL14)) Is
Nothing) Then
'in A35
Set mySheet = Sheet40
ElseIf Not (Intersect(.Cells, Me.Range(sPLAYERCELL15)) Is
Nothing) Then
'in A36
Set mySheet = Sheet26
Else
'not in either cell
Exit Sub
End If
sSheetName = .Value 'or .text if you have it formatted nicely
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