tonyrosen
12-02-2005, 07:14 AM
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?
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?