p2p.wrox.com Forums

p2p.wrox.com Forums (http://p2p.wrox.com/index.php)
-   Excel VBA (http://p2p.wrox.com/forumdisplay.php?f=79)
-   -   Tab Order Screwy (http://p2p.wrox.com/showthread.php?t=35725)

tonyrosen December 2nd, 2005 12:29 PM

Tab Order Screwy
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
        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"
            celTemp.PasteSpecial xlPasteValues
            celTemp.PasteSpecial xlPasteFormats
            .MergeCells = True


             'For some reason, celTemp.EntireRow.Height changes when .MergeCells=True
            If celTemp.EntireRow.Height > ReqdHeight Then ReqdHeight = celTemp.EntireRow.Height
        End With
    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)
        Set rg = Union(rg, Range(X))
    End If

Set targ = Intersect(rg, Target)
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
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?

krechet March 1st, 2006 07:11 PM

If you didn't find the solution yet, try this code for autofit merged cells.
I started with the same code as you found on the web and ended with complete redo.
 It is much easier on the worksheet
 it doesn;t incert or delet anything and leaves no trace/garbage anywhere.

Private Sub autoFit_Row_w_Merged_Cells(Target As Range, Optional addHeight As Double = 1)
    ' Autofits merged cells in the row.
    ' Fixes Excel bug in fitting
    ' Does this FAST
    ' created by Shura Krechetov, 2006,
    If ActiveSheet.ProtectContents Then
        MsgBox ("worksheet is protected. Can not do anything")
        Exit Sub
    End If
    'go over all all the merged ranges
    Dim r As Range, c As Range
    Dim ReqdHeight As Double
    ReqdHeight = 0
    Set r = Target.Cells(1, 1).EntireRow
    Dim col As Integer, colMax As Integer
    col = Target.Cells(1, 1).Column
    colMax = col + Target.Columns.Count - 1
    Do While col < colMax
        With r.Cells(1, col)
            If .MergeCells And .WrapText Then
                ' autofit row here

                ' calculate width of current merged area
                Dim mergedWidth As Double, mergedRange As Range
                Set mergedRange = .MergeArea
                mergedWidth = mergedRange.Width ' in points

                'unmerge cells
                .MergeCells = False
                'save the column width for the future recovery
                Dim tempColWidth As Double
                tempColWidth = .ColumnWidth

                ' make current column as wide as merged area
                ' one would ask why I convert from points (width)
                ' to characters (columnwidth) and back
                ' Apparently measurement in Columnwidth is much less accurate and
                ' I had a lot of problem matchin widthes with columnwidth
                ' Also Width property is applicable to therange and there is no
                ' need to cycle over all cells
                .ColumnWidth = points2char = 0.1905 * p - 0.7139 'Convert from points to "characters"
                ' fit it

                'save height for the moment look for maximum over the row
                If .RowHeight > ReqdHeight Then ReqdHeight = .RowHeight

                'recover current column width
                .ColumnWidth = tempColWidth

                mergedRange.MergeCells = True
                .EntireRow.RowHeight = Application.Max(ReqdHeight / mergedRange.Rows.Count + 0.5, 12.75) + addHeight
                'go to the next cell after merged area
                col = col + mergedRange.Columns.Count
                col = col + 1
            End If
        End With
End Sub

All times are GMT -4. The time now is 01:41 AM.

Powered by vBulletin®
Copyright ©2000 - 2020, Jelsoft Enterprises Ltd.
© 2013 John Wiley & Sons, Inc.