Tab Order Screwy

[tonyrosen]

Okay, first I used this code to "resize" my merged cells:


Sub AutoFitMergedCells(Target As Range)
'AutoFits a merged cell range, even though it is technically impossible
Dim MergedWidth As Double, NewHeight As Double, ReqdHeight As Double
Dim cel As Range, celTemp As Range, col As Range, colCopy As Range, rg As Range, rw As Range
Dim Mergers As New Collection
Dim i As Long, nMerge As Long, nRow As Long
Set rg = Target.Cells(1, 1)
If Not rg.MergeCells Then Exit Sub
Application.ScreenUpdating = False
'Identify all the merged ranges in this row
nRow = rg.Row
With Target.Parent 'The worksheet containing the range Target
For i = 1 To 256
If .Cells(nRow, i).MergeCells And .Cells(nRow, i).WrapText Then
nMerge = nMerge + 1
Mergers.Add Item:=.Cells(nRow, i).MergeArea
i = i + .Cells(nRow, i).MergeArea.Columns.Count - 1
End If
Next
Set colCopy = .Columns(256) '.Insert 'Insert an empty column
Set celTemp = colCopy.Cells(nRow, 1)
End With
For i = 1 To nMerge 'Loop through all the merged areas on this row
Set rg = Mergers(i)
With rg
MergedWidth = 0
Set cel = .Cells(1, 1)
For Each col In .Columns
MergedWidth = col.Width + MergedWidth 'Measured in points
Next col

.MergeCells = False
colCopy.ColumnWidth = 0.1905 * MergedWidth - 0.7139 'Convert from points to "characters"
cel.Copy
celTemp.PasteSpecial xlPasteValues
celTemp.PasteSpecial xlPasteFormats
.MergeCells = True

celTemp.EntireRow.AutoFit

'For some reason, celTemp.EntireRow.Height changes when .MergeCells=True
If celTemp.EntireRow.Height > ReqdHeight Then ReqdHeight = celTemp.EntireRow.Height
End With
Next
colCopy.ClearContents
i = Target.Parent.UsedRange.Rows.Count
Target.RowHeight = Application.Max(ReqdHeight / Target.Rows.Count + 0.49, 12.75) 'Round row height up to 0.5 points, minimum of 12.75 points
If ReqdHeight >= 409.5 Then MsgBox "Warning! Text is truncated because maximum merged cell height is 409.5 points"
Application.ScreenUpdating = True
End Sub


Then, we decided to "skip" empty field validation because after using it they believed me when I said it would be annoying. That being said, I had to find something for "tabbing" to the next field - and came across this piece of code in this forum.

In my 'Worksheet_SelectionChange" section I put:


Dim TabOrder As Variant, X As Variant
Dim addr As String
Dim rg As Range, targ As Range
If TabOrderFlag = True Then Exit Sub

TabOrder = Array("Range1", "Range2", "Range3", "Range4", "Range5", "Range8", "Range9", "Range10", "Range11", "Range12", "Range13", "Range14", "Range14a", "Range14b", "Range14c", "Range14d", "Range15") 'List your cell addresses in desired tab order here
For Each X In TabOrder
If rg Is Nothing Then
Set rg = Range(X)
Else
Set rg = Union(rg, Range(X))
End If
Next

Set targ = Intersect(rg, Target)
rg.Select
If targ Is Nothing Then
addr = Target.Cells(1, 1).Address(ColumnAbsolute:=False, RowAbsolute:=False)
X = Application.Match(addr, TabOrder, 0)
If IsError(X) Then Range(TabOrder(LBound(TabOrder))).Activate
Else
targ.Activate
End If


Then, in a module I had to put this:


Public TabOrderFlag As Boolean

Sub TabOrderMode()
TabOrderFlag = Not TabOrderFlag
End Sub


Now, my problem. The Auto Size Merged Cells code messes up the tab order. Whenever you place a piece of text in a cell, the Auto Size piece kicks in and then messes up the works.

Any ideas?

[tonyrosen]

Okay, I tried getting rid of the merged cells, but the sheet doesn't work without them because of it's nature.

I have narrowed it down to the Auto Fit Merged Cells code, it sends my active cell all the way over to column "IV". I just don't know how to fix it.

[mdmackillop]

Hi Tony,
The following is some code I made up a while ago for selected tab order. I've added some lines to deal with merged cells. Your MoveAfterEnter needs to be set to "Right"
Regards
MD


Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Long
i = 1
If Target.Cells.Count > 1 Then Exit Sub
If Not (Target.Offset(, -1).MergeCells) Then
DoTab Target.Offset(0, -1), True
Exit Sub
Else
Do Until Not (Target.Offset(, -i).MergeCells)
i = i + 1
Loop
DoTab Target.Offset(0, -i + 1), True
End If
End Sub

Sub DoTab(ByVal Target As Range, Optional Test1 As Boolean)
Dim aTabOrd As Variant
Dim i As Long, Test2 As Boolean
'Test1 and Test2 are set to false later to allow the code to run once only
If Test1 = False And Test2 = False Then
Application.EnableEvents = True
Exit Sub
End If
Test1 = False
'Set the tab order of input cells
aTabOrd = Array("B3", "B5", "B7", "B9", "F9", "B11", "F11", "B13", "F13", _
"B15", "B17", "B19", "B21", "B23", "B26", "E26", "B27", "E27", "B29", "E29", _
"B30", "E30", "B31", "E31", "B34", "C43", "B36", "B38", "B40", "B42")
'Loop through the array of cell address
For i = LBound(aTabOrd) To UBound(aTabOrd)
'If the cell that's changed is in the array
If aTabOrd(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
'Just to show what's happening
Selection.Interior.ColorIndex = 6
Test2 = True
Else
'Prevent selection change from running when selection is changed
Application.EnableEvents = False
'Select next cell in the array
Me.Range(aTabOrd(i + 1)).Select
Selection.Interior.ColorIndex = 6
'Setting Test2 to False forces exit from sub when it runs again
'from the penultimate line
Test2 = False
'For debbugging and avoidance of CRI in convoluted code.
'MsgBox Selection.Address(0, 0)
Exit For
End If
End If
Next i
'Running the code again resets the Application.EnableEvents
'to true before exiting the sub
DoTab Target
End Sub