Auto Row Height for Merged Cells

[Guest]

I'm working in Excel 2002.

My spreadsheet consists of columns A - AH, 22 rows. The last row, 22, is
merged to one cell, the lenght of A- AH. I would like the row to expand
based on the amount of text that is inputted into it. I have tried the
following coding but it doesn't seem to work.

Sub AutoFitMergedCellRowHeight()
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single

If ActiveCell.MergeCells Then
With ActiveCell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = ActiveCell.ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth + _
MergedCellRgWidth
MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
End If
End Sub

I have placed the above coding in Module2. The document is also protected
allowing the user access to input areas only.

I don't know why it's not working. Any help would be appreciated.

Thanks!

 

[Guest]

The appended code was adapted from a post by Jim Rech who, to my knowledge,
originated this approach. Your code also appears to have the same origin.

Ensure that the WrapText property of the merged cells is set to True. Paste
the code to the sheet code module: Hold the mouse pointer over the sheet tab
and right-click. Select View Code and then paste to the sheet code module.

My assumption is that the sheet is password protected. If not, delete the
line at the top: Const Pwd As String = "monkey" where monkey is assumed the
password. Also delete the two occurrences of Pwd following the Unprotect and
Protect statements. The code should Autofit the range automatically.

Dim OldRng As Range
Const Pwd As String = "monkey"

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim NewRwHt As Single
Dim cWdth As Single, MrgeWdth As Single
Dim c As Range, cc As Range
Dim ma As Range
Dim Protected As Boolean

Protected = False
Set c = Cells(22, 1)
If OldRng Is Nothing Then Set OldRng = c
If Not Intersect(OldRng, c) Is Nothing Then
Application.ScreenUpdating = False
If Me.ProtectContents Then
Protected = True
Me.Unprotect Pwd
End If
cWdth = c.ColumnWidth
Set ma = c.MergeArea
For Each cc In ma.Cells
MrgeWdth = MrgeWdth + cc.ColumnWidth
Next
ma.MergeCells = False
c.ColumnWidth = MrgeWdth
c.EntireRow.AutoFit
NewRwHt = c.RowHeight
c.ColumnWidth = cWdth
ma.MergeCells = True
ma.RowHeight = NewRwHt
cWdth = 0: MrgeWdth = 0
If Protected Then Me.Protect Pwd
Application.ScreenUpdating = True
End If
Set OldRng = Target
End Sub

Regards,
Greg

 

[Guest]

Thanks Greg, it seems to be working great. I appreciate your help!

 

[Guest]

Hi Greg, I miss spoke. I tested it without protecting the document.

Here is some more information that might help. The user can enter rows if
needed, so the Comments row can be row 22 and up. Currently there are 12
rows for the user, but as I said they can enter as many rows as they need.

I have removed the text you suggested from your coding. With the document
now protected, I cannot tab or click row 22 to enter text.

Any help you can provide is appreciated. Thanks!

 

[Guest]

I tested it at my end based on a simple worksheet set-up and it works fine.
Of course, all cells including the merged range need to be unlocked. It is
assumed you have done this. Granted, this doesn't explain why you can't tab
or click on the merged range unless you've set the EnableSelection property
to xlUnlockedCells.

The simplest solution, at this point, is to email me the workbook and I can
have a look at it this evening. If it is large and/or there is private
information, just make a copy and delete all unnecessary sheets (and code if
any) and email the stripped down version. Test the stripped-down version
first to ensure that it still exhibits this behavior.

Remove the "SpammersDie" from the below email address. Please mention Excel
in the subject because I have tons of spam to sift through.

(e-mail address removed)

Regards,
Greg

 

[Guest]

Hi Greg, I'll send the file to you. Thanks so much for taking time to help
me, I really appreciate it.

 

[Guest]

Jamie,

I have your spreadsheet working at my end. The problem was that when the
cells were automatically unmerged and then remerged, some of the cells in the
merged range became locked, apparently as a default behavior. This normally
isn't a problem, but I did at one point experience what you described. I
include a line of code to prevent the cells from relocking. I'm just guessing
it's something to do with inserting the rows. My experiments prior to my
orignial post included applying protection. Also, I'm no longer having the
problem with your spreadsheet even with some of the cells in the range
locked. I'll not attempt to resolve this tonight.

The other problem was that you declared OldRng inside of the
Selection_Change procedure instead of at module level (top of module). As
such, memory was lost immediately after the event completed. So, OldRng
always ends up being set to Nothing and is reset to c each time the macro
executes:
If OldRng Is Nothing Then Set OldRng = c
The procedure still worked but executed the AutoFit code no matter which
cell was selected. The way I suggested allows it only to execute if the
merged range was first selected. This should greatly reduce screen flicker.

If I were doing this (and I'm no expert), I would forget the option to
insert new rows - i.e. loose the button. Instead, just go with the one merged
range and have a note below the merged range (e.g. "Press Alt+Enter for new
line") in smaller font. The user should have all the room they need to enter
comments. Try this on a new sheet: Type into a cell and then hold down the
Alt key and press Enter, then type some more.

It is my preference for this sort of thing to set the worksheet's
EnableSelection property to xlUnlockedCells. This prevents the user from even
clicking on a cell that is locked when the sheet is protected. I would shade
all cells not intended for data entry as appropriate and leave entry cells
white. IMHO, this makes it intuitively obvious where to enter information and
greatly facilitates navigation. However, you have to reset this property each
time the workbook is opened because it defaults back to xlNoRestrictions. If
interested, place this code in the ThisWorkbook module and close and reopen:
Private Sub Workbook_Open()
With ThisWorkbook.Sheets("Sheet1")
.EnableSelection = UnlockedCells 'xlNoRestrictions to reset
End With
End Sub

The AutoFit code follows. After that, I append some interesting code by Dave
Perterson for future reference. I don't believe it is suitable for merged
cells.

Best regards,
Greg

Dim OldRng As Range ' DECLARED THIS AT TOP OF MODULE
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim NewRwHt As Single
Dim cWdth As Single, MrgeWdth As Single
Dim c As Range, cc As Range
Dim ma As Range
Dim Protected As Boolean

If Target.Column = 35 Then 'If last column is 36 then
Cells(Target.Row, 2).Select 'go to the same row, first cell
End If
Protected = False
Set c = Cells(22, 1)
If OldRng Is Nothing Then Set OldRng = c
If Not Intersect(OldRng, c) Is Nothing Then
Application.ScreenUpdating = False
If Me.ProtectContents Then
Protected = True
Me.Unprotect
End If
cWdth = c.ColumnWidth
Set ma = c.MergeArea
For Each cc In ma.Cells
MrgeWdth = MrgeWdth + cc.ColumnWidth
Next
ma.MergeCells = False
c.ColumnWidth = MrgeWdth
c.EntireRow.AutoFit
NewRwHt = c.RowHeight
c.ColumnWidth = cWdth
ma.MergeCells = True
ma.RowHeight = NewRwHt
cWdth = 0: MrgeWdth = 0
ma.Locked = False
If Protected Then Me.Protect
Application.ScreenUpdating = True
End If
Set OldRng = Target
End Sub

Dave Peterson's code:-
This is an interesting way of converting a single cell to act like a text
box without the grief that comes with them. I have not implemented it in any
of my own projects only because I have not got around to it yet. So I don't
have any actual experience. I think I would implement it in conjunction with
EnableSelection set to xlUnlockedCells as discussed above.

When you execute the first macro ("RemapEnterToAltEnter"), it remaps the
Enter key to, instead of causing a step down, create a new line within the
same cell. In other words, you can rig it such that a single cell acts like a
text box for user comments. Using the Worksheet Selection_Change event, you
should be able to rig it such that selecting this cell executes
RemapEnterToAltEnter in order to create the behavior; and if any other cell
is selected, to execute the ResetEnterKeys to return to normal. I would size
this cell to the maximum the user would need - this has nothing to do with
AutoFit.

Sub RemapEnterToAltEnter()
'Application.OnKey "{Enter}", "doAltEnter" 'numeric key pad
Application.OnKey "~", "doAltEnter" 'QWERTY
End Sub
Sub DoAltEnter()
If Not ActiveCell.HasFormula Then
ActiveCell.Value = ActiveCell.Value & Chr(10)
SendKeys "{f2}{end}{right}"
End If
End Sub
Sub ResetEnterKeys()
'Application.OnKey "{enter}" 'numeric
Application.OnKey "~" 'QWERTY
End Sub

 

[Guest]

Hi Greg, I entered your revised coding and it is working with one hitch. I'm
assuing the user will insert their Comments after they input the data. If
the user inserts rows then the Comments row is no longer Row 22 and the row
does not expand.

Can the Set c = Cells(22,1) be changed to accomadate whatever row number
Comments happens to be, whether it's Row 22 or 63 or more? The Comments row
number is dependent on how many rows the user inserts above it.

Thanks!

 

[Guest]

Jamie,

I took a few liberties:
1) I set it up so that you will also need a Delete button. It was a problem
if Comments rows were manually deleted and I'm sure you could use this
functionality.
2) I rigged it so that both the Insert Rows and Delete Rows buttons are
visible only when the Comments range is selected. IMHO, this gives it an
extra bit of snaz and it simplifies the code requirement. Otherwise, the
button macros would have to determine the scope of the Comments range (which
varies) each time, and to determine if the active cell is within the range,
and to work only if this is the case. Since the buttons are not available
when selection is outside of the Comments range then this code is only
required in the Selection_Change macro.
3) I removed the MsgBox feature from the AddRow macro since there is no
consequence to adding a row and this speeds it up.
4) I call a MsgBox with the DeleteRow macro only if there is text within the
row to be deleted else the row is deleted immediately on button click. This
streamlines performance.
5) If there is only one row left in the Comments section then I refuse row
deletion. A MsgBox (vbCritical) advises in this case.
6) Instead of adding an entire row, the AddRow macro only adds a range of
cells and merges them. Therefore, if there is anything to the right and below
this range it is not affected.

Instructions:
1) Delete the code I gave you previous.
2) Add a new button similar to the one you alredy have and make its caption
"Delete Row".
3) A very minor point, but I suggest "Insert Row" instead of "Insert a Row"
for the existing button.
4) Paste the new Worksheet Selection_Change code to the sheet module.
5) Paste the two macros "AddRow" and "DeleteRow" to a standard module.
6) Ensure that the declaration: Public OldRng As Range is in the standard
module along with the button macros (at the top of the module).
7) Ensure that cells below the Comments range are not merged. The extent of
the Comments range is determined using a loop to find the end of merged cells.
8) Ensure that the two buttons are the first and second shapes added to the
worksheet in case there are others. The code assumes this.

Hope all goes well. Please advise on the outcome. I need the feedback since
I'm only a student.

Regards,
Greg

'Paste to Sheet1 code module as before
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim NewRwHt As Single
Dim cWdth As Single, MrgeWdth As Single
Dim c As Range, cc As Range
Dim MrgRng As Range, ma As Range
Dim i As Integer
Dim Protected As Boolean

If Target.Column = 35 Then
Cells(Target.Row, 2).Select
End If

Set c = Cells(22, 1)
i = c.Row
Do Until Cells(i, 1).MergeArea.Count < 34
i = i + 1
Loop
If OldRng Is Nothing Then Set OldRng = c
Set MrgRng = Range(c, Cells(i - 1, 34))
ActiveSheet.Shapes.Range(Array(1, 2)).Visible = _
(Not Intersect(ActiveCell, MrgRng) Is Nothing)
If Not Intersect(OldRng, MrgRng) Is Nothing Then
Set c = OldRng
Application.ScreenUpdating = False
Protected = False
If Me.ProtectContents Then
Protected = True
Me.Unprotect
End If
cWdth = c.ColumnWidth
Set ma = c.MergeArea
For Each cc In ma.Cells
MrgeWdth = MrgeWdth + cc.ColumnWidth
Next
ma.MergeCells = False
c.ColumnWidth = MrgeWdth
c.EntireRow.AutoFit
NewRwHt = c.RowHeight
c.ColumnWidth = cWdth
ma.MergeCells = True
ma.RowHeight = NewRwHt
cWdth = 0: MrgeWdth = 0
ma.Locked = False
If Protected Then Me.Protect
Application.ScreenUpdating = True
End If
Set OldRng = ActiveCell
End Sub


Option Explicit
'Declare OldRng this time in standard module at top
Public OldRng As Range
'Paste AddRow to standard module
Sub AddRow()
Dim rng As Range, NewRow As Range
ActiveSheet.Unprotect
Set rng = ActiveCell.MergeArea
Set NewRow = rng(2, 1)
NewRow.Resize(1, 34).Insert
With NewRow(0, 1).Resize(1, 34)
.RowHeight = 12.75
.MergeCells = True
.WrapText = True
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.Locked = False
End With
End Sub

'Paste DeleteRow to standard module
Sub DeleteRow()
Dim Msg As String, Title As String
Dim Style As Integer, i As Integer
Dim c As Range, rng As Range
Dim ShowMsg As Boolean

Set c = Cells(22, 1)
i = c.Row
Do Until Cells(i, 1).MergeArea.Count < 34
i = i + 1
Loop
Title = "Delete Comments Row"
If i = 23 Then
Msg = "Action denied !!!" & vbCr & vbCr & _
"Cannot delete last Comments row. "
Style = vbCritical + vbOKOnly
MsgBox Msg, Style, Title
Exit Sub
ElseIf Len(Trim(ActiveCell)) > 0 Then
ShowMsg = True
Msg = "Delete selected Comments row ?" & vbCr & vbCr & _
"All information in the selected row will be lost. "
Style = vbExclamation + vbYesNo + vbDefaultButton2
End If
ActiveSheet.Unprotect
Set rng = ActiveCell.MergeArea
If ShowMsg Then
If MsgBox(Msg, Style, Title) = vbNo Then Exit Sub
End If
rng.Delete
With Application
If ActiveCell.Row = i - 1 Then
.EnableEvents = False
Cells(i - 2, 1).Select
.EnableEvents = True
End If
End With
Set OldRng = ActiveCell
End Sub

 

[abcd]

I'm using an other way:
I copy the content of the merged-cells in an other unique cell (same
row, out of the printed and viewved area). This other cell is large
enought (same as all the merged cells). This one can fix the
auto-fit-height of the current row, and will make the merged area to be
at the good height.

(sometimes it works better to have the separated cell to have the
value and the merged one to copy from it)

 

[Guest]

I've tried that myself. I used formulae that refer to the active cells of the
merged ranges instead of copying, and used code to force the AutoFit of these
single cells. I format the font colour the same as the cell interior colour
to make it invisible.

There is a problem, however, with the fact that text wrap doesn't act the
same for single cells as it does for merged ranges sized the same. A
correction factor is beneficial but isn't that reliable. So it ends up not
being that elegant. Mine (adapted from Jim Rech's code) has the same problem
in this respect but doesn't require extra real estate. There is the added
complexity of the row insertion and deletion. Six of one and half a dozen of
the other IMHO.

Best regards,
Greg

 

[abcd]

hum,
maybe it depends on the font used, because I do not have this
extra-factor you said. Same width brings same line breaks.
But I know excel has come problems with true fonts or not (sometimes
when printing the width of text is not the same than on screen even with
true fonts). So you may have this problem I can believe you.

 

[Guest]

Hi Greg, sorry for the delayed response, I've been on vacation. I've checked
with the requestor of the form and they do not want a Delete Rows button
added. So I'm still stuck on having the Comments row expand to the amount of
text. If I can't have the row expand to the amount of text, I guess I will
make it a certain height and if the text doesn't fit, it doesn't fit. I'm
not sure what else to do to get this working. Thanks so much for your time,
I really appreciated it.

 

[Guest]

You might want to consider using Dave Perterson's code as I mentioned
earlier. I was too hasty in saying that it is not compatible with merged
cells. I don't know why I said that.

As I suggested, it can be rigged so that when the user clicks inside the
Comments range (say this is one row of cells merged across columns), then
this action causes the Enter key to remap, so that pressing it is the same as
holding down the Alt key and pressing Enter (Alt+Enter). Therefore, instead
of stepping down a row, is starts a new line within the same cell (or merged
range in this case) similar to pressing Enter in a Word document. You would
have to click outside of the Comments range to deactivate this behavior.

You need to set the vertical alignment property of the active cell to Top
and the horizontal alignment to Left (Format>Cells>Alignment tab). The
AutoFit option is still compatable with this approach as well as the
alternate mentioned by "abcd". I would combine this with setting the
EnableSelection property for the worksheet to xlUnlocked cells and protect
the worksheet. Therefore, the user can't even click on locked cells.

I typically make locked cells gray except those containing formulae which I
make, say, light blue. I make all cells intended for data entry white. The
user can only click on the white cells since they are the only ones that are
not locked. Granted, as I said previously, I have yet to implement this for a
project of mine, so I don't have any actual experience.

If interested, I could set it up for you.

Regards,
Greg