Tab movement using Tab Key. Active Cell Color Change

[DarrenBurke]

Hi Guys and Ladies

I have an Array for using the Tab Key. I would like the color (colour... for english UK) of the active cell to change as the user tabs through the sheet. Basically to see what cell he/she is currently on.

My code for the sheet. Tab key works perfect, a bit of bling would be nice Cheers and thank you for the help.

Private Sub TabOrder()
     
     'Set applicable sheet name
    Const TabSheet = "PICKUP COPY1"
    Dim Limit As Integer, NumPos As Integer
    Dim NextPos As String, MyCel As String
    Dim MyTO
     
     'Set tab offset for other sheets
    If ActiveSheet.Name <> TabSheet Then
        ActiveCell.Offset(0, 1).Select
        Exit Sub
    End If
     'Set your cells in desired order
    MyTO = Array("C7", "C6", "E4", "C8", "C10", "C12", "C14", "C16", "C18", "C20", "C22", "C24", "D24", "E24", "C26", "C32", "F34", "A36", "I7", "I6", "K4", "I8", "I10", "I12", "I14", "I16", "I18", "I20", "I22", "I24", "J24", "K24", "I26", "I32", "L34", "G36", "O7", "O6", "Q4", "O8", "O10", "O12", "O14", "O16", "O18", "O20", "O22", "O24", "P24", "Q24", "O26", "O32", "R34", "M36", "S46")
    Limit = UBound(MyTO)
    MyCel = ActiveCell.Address(0, 0)
     'Check for match in array
    On Error GoTo LastLine
    NumPos = Application.WorksheetFunction.Match(MyCel, MyTO, 0)
     'Return to first cell
    If NumPos = Limit Then
        NextPos = MyTO(1)
    Else
        NextPos = MyTO(NumPos + 1)
    End If
    Range(NextPos).Activate
    Exit Sub
LastLine:
     'Set tab offset if named cell not found
    ActiveCell.Offset(0, 1).Select
End Sub

 

[Jimmypop]

Good day

Maybe try the following on the sheet code...

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Cells.Interior.ColorIndex = xlNone
   ActiveCell.Interior.ColorIndex = 3
End Sub

 

[DarrenBurke]

Good day

Maybe try the following on the sheet code...

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Cells.Interior.ColorIndex = xlNone
   ActiveCell.Interior.ColorIndex = 3
End Sub

Hi Jimmy. Thank you for responding. Inserted code into top of sheet. Does not change colour when tabbing.

Option Explicit
Option Base 1
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   Cells.Interior.ColorIndex = xlNone
   ActiveCell.Interior.ColorIndex = 3
End Sub
Private Sub TabOrder()
    
     'Set applicable sheet name
    Const TabSheet = "PICKUP COPY1"
    Dim Limit As Integer, NumPos As Integer
    Dim NextPos As String, MyCel As String
    Dim MyTO
          
     'Set tab offset for other sheets
    If ActiveSheet.Name <> TabSheet Then
        ActiveCell.Offset(0, 1).Select
        Exit Sub
    End If
     'Set your cells in desired order
    MyTO = Array("C7", "C6", "E4", "C8", "C10", "C12", "C14", "C16", "C18", "C20", "C22", "C24", "D24", "E24", "C26", "C32", "F34", "A36", "I7", "I6", "K4", "I8", "I10", "I12", "I14", "I16", "I18", "I20", "I22", "I24", "J24", "K24", "I26", "I32", "L34", "G36", "O7", "O6", "Q4", "O8", "O10", "O12", "O14", "O16", "O18", "O20", "O22", "O24", "P24", "Q24", "O26", "O32", "R34", "M36", "S46")
    Limit = UBound(MyTO)
    MyCel = ActiveCell.Address(0, 0)
     'Check for match in array
    On Error GoTo LastLine
    NumPos = Application.WorksheetFunction.Match(MyCel, MyTO, 0)
     'Return to first cell
    If NumPos = Limit Then
        NextPos = MyTO(1)
    Else
        NextPos = MyTO(NumPos + 1)
    End If
    Range(NextPos).Activate
    Exit Sub
LastLine:
     'Set tab offset if named cell not found
    ActiveCell.Offset(0, 1).Select
    Cells.Interior.ColorIndex = xlNone
   ActiveCell.Interior.ColorIndex = 3
End Sub



Sub RESET_FORM()
'
' RESET_FORM Macro
' Macro recorded 2005/01/27 by Darren Burke
'
' Keyboard Shortcut: Ctrl+z
'
    Dim DelRange As Range, RefRange As Range, NumRange As Range, QtyRange As Range
    Set DelRange = Union(Range("C7:E7", "C6"), Range("I7:K7", "I6"), Range("O7:Q7", "O6"), _
        Range("C32:F32"), Range("I32:L32"), Range("O32:R32"), Range("A36:F36"), Range("G36:L36"), Range("M36:R36"))
    Set RefRange = Union(Cells(3, 4), Cells(3, 10), Cells(3, 16))
    Set NumRange = Union(Cells(3, 5), Cells(3, 11), Cells(3, 17))
    Set QtyRange = Union(Range("F34"), Range("L34"), Range("R34"), Range("E4"), Range("K4"), Range("Q4"))
    DelRange.ClearContents
    RefRange.Formula = "Ref"
    NumRange.Formula = "Num"
    QtyRange.Formula = 1
    GetTelNos
    Range("C7").Select
    
End Sub

Sub GetTelNos()
    Dim Tmp As String
    Tmp = "$A$2:" & Sheets("database Building").Range("B1").End(xlDown).Offset(0, -1).AddressLocal
    ActiveWorkbook.Names.Add Name:="TelNos", RefersTo:= _
        "='DATABASE BUILDING'!" & Tmp

End Sub

 

[Jimmypop]

And if you remove...

    Cells.Interior.ColorIndex = xlNone
   ActiveCell.Interior.ColorIndex = 3

From...

LastLine:
     'Set tab offset if named cell not found
    ActiveCell.Offset(0, 1).Select
    Cells.Interior.ColorIndex = xlNone
   ActiveCell.Interior.ColorIndex = 3

 

[DarrenBurke]

And if you remove...

    Cells.Interior.ColorIndex = xlNone
   ActiveCell.Interior.ColorIndex = 3

From...

LastLine:
     'Set tab offset if named cell not found
    ActiveCell.Offset(0, 1).Select
    Cells.Interior.ColorIndex = xlNone
   ActiveCell.Interior.ColorIndex = 3

Sorry Jimmy Struggling a little, how does one upload the file its small 264kb

 

[Jimmypop]

Sorry Jimmy Struggling a little, how does one upload the file its small 264kb

You can link a dropbox or google drive link if you have...

 

[DarrenBurke]

You can link a dropbox or google drive link if you have...

Cherryl PickupMaster.xlsm

Shared with Dropbox

www.dropbox.com

Protected sheet if needed is .... press space bar once and then number 1 and enter
Thank you for your time

 

[Jimmypop]

Got it thank... must it only run on Pickup1 (Sheet7) or on all sheets...

 

[DarrenBurke]

Got it thank... must it only run on Pickup1 (Sheet7) or on all sheets...

Hi only on sheet7 ...... sheet2 is a mirror to restore the sheet7 after capture

Thank you Jimmy

 

[Jimmypop]

Just give me maybe tonight to work on it at home... If anyone else in the meantime wants to give a go they are welcome...

Some issues encountered is if I apply the code it removes the yellow highlighting you have in place already so will need to investigate a workaround for that