VBA Code for Tab order

[kevindow]

How can I create a custom tab order (for example A1-B6-D4 etc...) that is not contingent on a protected worksheet. I have found the following code on-line but I am having some issues with the code. For one it only advances via tab if I enter a change into a given cell. Another problem is if I enter data inside a cell that is not listed in the code it gives an error message. Any suggestions.

Private Sub Worksheet_Change(ByVal Target As Range) Dim aTabOrd As Variant Dim i As Long 'Set the tab order of input cells aTabOrd = Array("A5", "B5", "C5", "A10", "B10", "C10") 'Loop through the array of cell address For i = LBound(aTabOrd) To UBound(aTabOrd) 'If the cell that's changed is in the array IfaTabOrd(i) = Target.Address(0, 0) Then 'If the cell that's changed is the last in the array If i =UBound(aTabOrd) Then 'Select first cell in the array Me.Range(aTabOrd(LBound(aTabOrd))).Select Else'Select next cell in the array Me.Range(aTabOrd(i + 1)).Select End If End If Next i End Sub

 

[Jerry Sullivan]

Hi Kevin, Just following up to post the code I sent you in your example file. It sounds like this modified version does what you wanted.

These procedures replace the previous ones in the Standard Code module. The procedures in the ThisWorkbook and Sheet Code modules are unchanged.

Sub SetOnkey(ByVal state As Boolean)
    If state Then
        With Application
            .OnKey "{TAB}", "'TabRange xlNext'"
            .OnKey "~", "'TabRange xlNext'"
            .OnKey "{RIGHT}", "'TabRange xlNext'"
            .OnKey "{LEFT}", "'TabRange xlPrevious'"
            .OnKey "{DOWN}", "'UpOrDownArrow xlDown'"
            .OnKey "{UP}", "'UpOrDownArrow xlUp'"
        End With
    Else
    'reset keys
        With Application
            .OnKey "{TAB}"
            .OnKey "~"
            .OnKey "{RIGHT}"
            .OnKey "{LEFT}"
            .OnKey "{DOWN}"
            .OnKey "{UP}"
        End With
    End If
End Sub


Function GetTabOrder() As Variant
'--set the tab order of input cells - change ranges as required
'  don't include "$" in these cell references

GetTabOrder = Array("D8", "F8", "H8", "L6", "L8", "D12", _
   "D18", "F18", "H18", "L16", "L18", "D22", _
   "D28", "F28", "H28", "L26", "L28", "D32")

End Function

Sub TabRange(Optional iDirection As Integer = xlNext)

Dim vTabOrder As Variant, m As Variant
Dim lItems As Long, iAdjust As Long

'--get the tab order from shared function
vTabOrder = GetTabOrder

lItems = UBound(vTabOrder) - LBound(vTabOrder) + 1

On Error Resume Next
m = Application.Match(ActiveCell.Address(0, 0), vTabOrder, False)
On Error GoTo ExitSub

'--if activecell is not in Tab Order return to the first cell
If IsError(m) Then
   m = 1
Else
   '--get adjustment to index
   iAdjust = IIf(iDirection = xlPrevious, -1, 1)

   '--calculate new index wrapping around list
   m = (m + lItems + iAdjust - 1) Mod lItems + 1
End If

'--select cell adjusting for Option Base 0 or 1
Application.EnableEvents = False
Range(vTabOrder(m + (LBound(vTabOrder) = 0))).Select

ExitSub:
   Application.EnableEvents = True
End Sub

Sub UpOrDownArrow(Optional iDirection As Integer = xlUp)

Dim vTabOrder As Variant
Dim lRowClosest As Long, lRowTest As Long
Dim i As Long, iSign As Integer

Dim sActiveCol As String
Dim bFound As Boolean

'--get the tab order from shared function
vTabOrder = GetTabOrder

'--find TabCells in same column as ActiveCell in iDirection
'--  rTest will include ActiveCell

sActiveCol = GetColLtr(ActiveCell.Address(0, 0))

iSign = IIf(iDirection = xlDown, -1, 1)
lRowClosest = IIf(iDirection = xlDown, Rows.Count + 1, 0)

For i = LBound(vTabOrder) To UBound(vTabOrder)
   If GetColLtr(CStr(vTabOrder(i))) = sActiveCol Then
      lRowTest = Range(CStr(vTabOrder(i))).Row
         
   '--find closest cell to ActiveCell in rTest
      If iSign * lRowTest > iSign * lRowClosest And _
         iSign * lRowTest < iSign * ActiveCell.Row Then
         '--at least one cell in iDirection of same columnn
         bFound = True
         lRowClosest = lRowTest
      End If
   End If
Next i

If bFound Then
   Application.EnableEvents = False
   Cells(lRowClosest, ActiveCell.Column).Select
   Application.EnableEvents = True
End If
End Sub


Private Function GetColLtr(sAddr As String) As String
Dim iPos As Long, sTest As String

Do While iPos < 3
   iPos = iPos + 1
   If IsNumeric(Mid(sAddr, iPos, 1)) Then
      Exit Do
   Else
      sTest = sTest & Mid(sAddr, iPos, 1)
   End If
Loop

GetColLtr = sTest
 
End Function

 

[Raustin]

Thanks you sooo much Jerry. You are a kind and generous person. I wanted to take a moment to let you know your input here has helped me considerably. Thanks again.

 

[Jerry Sullivan]

Hi Raustin, Thank you for your kind feedback.

 

[ChuckDrago]

Jerry Sullivan's code includes an array where the cell addresses participating in the tab ordering sequence are contained. I have a worksheet where one of the "cells" to be considered is not a cell but a merged range "I19:Q23" (multiple columns and rows). Is it possible to access such range using Jerry's code array and then continue to the next cell downstream in it?

 

[Jerry Sullivan]

Hi ChuckDrago, If you add "I19" (the TopLeft cell of the merged range) into array of cell addresses, the code should cycle to that as another step in the Tab order.

The up and down arrow functionality that was added in post #21 will work to allow cycling through cells in the Tab array that have their TopLeft cells in the same column.

Does that do what you are wanting?

 

[ChuckDrago]

Jerry, most appreciative for your quick response. I will try it and report back.
Chuck
PS. I had replied before with the wrong response, thus editing this reply accordingly.

 

[ChuckDrago]

Jerry, your code works EXACTLY as desired. Carload of thanks to you!
Chuck

 

[avalenti]

This is exactly what I have been searching for and my only question is how to use this for multiple sheets with different tab orders? Thanks for the help.

 

[avalenti]

If anybody does not know how to make this code viable with multiple pages here is what to do.

IN THIS WORKBOOK: Add another sheet in the Activate function and a new SetOnKey (all i did was add a 1 at the end)

Private Sub Workbook_WindowActivate(ByVal Wn As Window)
If ActiveSheet.Name = "Sheet 1" Then SetOnkey True
If ActiveSheet.Name = "Sheet 2" Then [COLOR=#ff0000]SetOnkey1[/COLOR] True
End Sub
 


Private Sub Workbook_WindowDeactivate(ByVal Wn As Window)
SetOnkey False
[COLOR=#ff0000]SetOnkey1[/COLOR] False
End Sub

IN THE WORKSHEET: Add the activate and deactivate but dont forget to change the sheet name and change it to the correct SetOnKey.

Private Sub Workbook_WindowActivate(ByVal Wn As Window)
If ActiveSheet.Name = "Sheet 2" Then [COLOR=#ff0000]SetOnkey1[/COLOR] True
End Sub


 
Private Sub Workbook_WindowDeactivate(ByVal Wn As Window)
[COLOR=#ff0000]SetOnkey1[/COLOR] False
End Sub

Add a new module and change the name of the SetOnKey to SetOnKey1 and TabRange to TabRange1 (again I added a 1 at the end of the name and you should for each sheet...etc SetOnKey2 and so on...) and dont forget to change the array for the tab sequence.

Sub [COLOR=#ff0000]SetOnkey1[/COLOR](ByVal state As Boolean)
    If state Then
        With Application
            .OnKey "{TAB}", "'TabRange1 xlNext'"
            .OnKey "~", "'TabRange1 xlNext'"
            .OnKey "{RIGHT}", "'TabRange1 xlNext'"
            .OnKey "{LEFT}", "'TabRange1 xlPrevious'"
            .OnKey "{DOWN}", "do_nothing"
            .OnKey "{UP}", "do_nothing"
        End With
    Else
    'reset keys
        With Application
            .OnKey "{TAB}"
            .OnKey "~"
            .OnKey "{RIGHT}"
            .OnKey "{LEFT}"
            .OnKey "{DOWN}"
            .OnKey "{UP}"
        End With
    End If
End Sub




Sub do_nothing()
'nothing to do
End Sub




Sub [COLOR=#ff0000]TabRange1[/COLOR](Optional iDirection As Integer = xlNext)


Dim vTabOrder As Variant, m As Variant
Dim lItems As Long, iAdjust As Long


'--set the tab order of input cells - change ranges as required
vTabOrder = [COLOR=#ff0000]Array("D14", "D15", "D16", "D17", "D18", "D19", "D20", "D21", "D22", "D23", "D24", "D25", "D26", "D27", "D28", "D29", "D30", "D31", "D32", "D33", "D34")[/COLOR]
lItems = UBound(vTabOrder) - LBound(vTabOrder) + 1


On Error Resume Next
m = Application.Match(ActiveCell.Address(0, 0), vTabOrder, False)
On Error GoTo ExitSub


'--if activecell is not in Tab Order return to the first cell
If IsError(m) Then
   m = 1
Else
   '--get adjustment to index
   iAdjust = IIf(iDirection = xlPrevious, -1, 1)


   '--calculate new index wrapping around list
   m = (m + lItems + iAdjust - 1) Mod lItems + 1
End If


'--select cell adjusting for Option Base 0 or 1
Application.EnableEvents = False
Range(vTabOrder(m + (LBound(vTabOrder) = 0))).Select


ExitSub:
   Application.EnableEvents = True
End Sub

Hopefully I have explained this well as I am not a full fledged programmer but took some C++ classes in college.

If anyone would care to elaborate or explain this better, go for it.

But I hope this helps if anyone did not know how to do this.

 

[avalenti]

The above actually did not work... Sheet 2 would tab correctly but sheet 1 would not... If anyone can help? Thanks