|
|
Our Hot Pick: Rising Antivirus 2006 - Certified by TUV & Checkmark! Get 10% discount by entering this coupon code: ONDISCOUNT10
Why does the "Autofit" feature for row heights not work with merged cells?
Is there a way to get this to work.
|
|
I know there is the following macro that can be used to fix this problem, but
could someone tell me how to implement it step-by-step. Thanks!
Sub AutoFitMergedCellRowHeight()
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range, RangeWidth As Single
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
RangeWidth = .Width
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth +
MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
While .Cells(1).Width < RangeWidth
.Cells(1).ColumnWidth = .Cells(1).ColumnWidth + 0.5
Wend
.Cells(1).ColumnWidth = .Cells(1).ColumnWidth - 0.5
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
End If
End Sub
|
|
Copy the code from the post.
With Excel open and your workbook open, hit ALT + F11.
Hit CTRL + r to open Project Explorer.
Select your workbook/project.
Right-click on the name and Insert>Module
Paste the code into that module.
Note: the code has a line wrap that will cause a problem. Fix it at this
point..
These two lines should be one line
MergedCellRgWidth = CurrCell.ColumnWidth +
MergedCellRgWidth
You can add a line continuation character after the + sign
That would be the + sign then a space then underscore _
MergedCellRgWidth = CurrCell.ColumnWidth + _
MergedCellRgWidth
Save the workbook.
ALT + Q to return to Excel.
Tools>Macro>Macros.
Select the macro and "Run"
Gord Dibben MS Excel MVP
On Tue, 25 Jul 2006 11:42:11 -0700, bbddvv <bbddvv[ at ]discussions.microsoft.com>
wrote:
[Quoted Text] >I know there is the following macro that can be used to fix this problem, but
>could someone tell me how to implement it step-by-step. Thanks!
>
>Sub AutoFitMergedCellRowHeight()
> Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
> Dim CurrCell As Range, RangeWidth As Single
> 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
> RangeWidth = .Width
> For Each CurrCell In Selection
> MergedCellRgWidth = CurrCell.ColumnWidth +
>MergedCellRgWidth
> Next
> .MergeCells = False
> .Cells(1).ColumnWidth = MergedCellRgWidth
> While .Cells(1).Width < RangeWidth
> .Cells(1).ColumnWidth = .Cells(1).ColumnWidth + 0.5
> Wend
> .Cells(1).ColumnWidth = .Cells(1).ColumnWidth - 0.5
> .EntireRow.AutoFit
> PossNewRowHeight = .RowHeight
> .Cells(1).ColumnWidth = ActiveCellWidth
> .MergeCells = True
> .RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
> CurrentRowHeight, PossNewRowHeight)
> End If
> End With
> End If
>End Sub
|
|
The code you posted was originally developed by Jim Rech. This is an adaption
of his code from a recent post of mine. Paste to the worksheet's code module.
To do so, right click the worksheet's tab and select View Code to access the
code module. Also, ensure that the WrapText property of the merged cells is
set to True through Format > Cells > Alignment tab.
Private Sub Worksheet_Change(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
With Target
If .MergeCells And .WrapText Then
Set c = Target.Cells(1, 1)
cWdth = c.ColumnWidth
Set ma = c.MergeArea
For Each cc In ma.Cells
MrgeWdth = MrgeWdth + cc.ColumnWidth
Next
Application.ScreenUpdating = False
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
Application.ScreenUpdating = True
End If
End With
End Sub
Regards,
Greg
|
|
what is this new code? It didn't work even though i fixed the line of code
that was on 2 lines. Ugh.
"Greg Wilson" wrote:
[Quoted Text] > The code you posted was originally developed by Jim Rech. This is an adaption
> of his code from a recent post of mine. Paste to the worksheet's code module.
> To do so, right click the worksheet's tab and select View Code to access the
> code module. Also, ensure that the WrapText property of the merged cells is
> set to True through Format > Cells > Alignment tab.
>
>
> Private Sub Worksheet_Change(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
>
> With Target
> If .MergeCells And .WrapText Then
> Set c = Target.Cells(1, 1)
> cWdth = c.ColumnWidth
> Set ma = c.MergeArea
> For Each cc In ma.Cells
> MrgeWdth = MrgeWdth + cc.ColumnWidth
> Next
> Application.ScreenUpdating = False
> 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
> Application.ScreenUpdating = True
> End If
> End With
> End Sub
>
> Regards,
> Greg
|
|
Thanks for jumping in Greg
I was going to google for your adaptation but got sidetracked.
And no line wraps<g>
Gord
On Tue, 25 Jul 2006 12:15:01 -0700, Greg Wilson
<GregWilson[ at ]discussions.microsoft.com> wrote:
[Quoted Text] >The code you posted was originally developed by Jim Rech. This is an adaption
>of his code from a recent post of mine. Paste to the worksheet's code module.
>To do so, right click the worksheet's tab and select View Code to access the
>code module. Also, ensure that the WrapText property of the merged cells is
>set to True through Format > Cells > Alignment tab.
>
>
>Private Sub Worksheet_Change(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
>
>With Target
>If .MergeCells And .WrapText Then
>Set c = Target.Cells(1, 1)
>cWdth = c.ColumnWidth
>Set ma = c.MergeArea
>For Each cc In ma.Cells
>MrgeWdth = MrgeWdth + cc.ColumnWidth
>Next
>Application.ScreenUpdating = False
>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
>Application.ScreenUpdating = True
>End If
>End With
>End Sub
>
>Regards,
>Greg
|
|
Don't know why the first set of code will not work for you.
What does "does not work" mean to you?
Nothing happens? The wrong thing happens?
The code that Greg posted is placed in a different module than the code we
originally looked at.
Greg's is event code not regular macro sub routine.
To use the code in this post, copy it.
Select the sheet tab in your workbook and "View Code"
Paste into that module.
Gord Dibben MS Excel MVP
On Tue, 25 Jul 2006 12:56:02 -0700, bbddvv <bbddvv[ at ]discussions.microsoft.com>
wrote:
[Quoted Text] >what is this new code? It didn't work even though i fixed the line of code
>that was on 2 lines. Ugh.
>
>
>
>"Greg Wilson" wrote:
>
>> The code you posted was originally developed by Jim Rech. This is an adaption
>> of his code from a recent post of mine. Paste to the worksheet's code module.
>> To do so, right click the worksheet's tab and select View Code to access the
>> code module. Also, ensure that the WrapText property of the merged cells is
>> set to True through Format > Cells > Alignment tab.
>>
>>
>> Private Sub Worksheet_Change(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
>>
>> With Target
>> If .MergeCells And .WrapText Then
>> Set c = Target.Cells(1, 1)
>> cWdth = c.ColumnWidth
>> Set ma = c.MergeArea
>> For Each cc In ma.Cells
>> MrgeWdth = MrgeWdth + cc.ColumnWidth
>> Next
>> Application.ScreenUpdating = False
>> 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
>> Application.ScreenUpdating = True
>> End If
>> End With
>> End Sub
>>
>> Regards,
>> Greg
|
|
If you were refering to my code, I copied it just now from my post and pasted
it directly to the worksheet's code module. It is working fine. There was no
need to correct anything (no word wrap caused by the post).
1. You have to paste it to the worksheet's code module: Right click the
worksheet's tab and select View Code. Then paste it.
2. The WrapText property of the merged cells has to be set to True.
3. The merged cells must be merged horizontally (e.g. A2 + B2 + C2 etc.) as
opposed to vertically (e.g. A2 + A3 + A4...). If your cells are merged
vertically then the code won't work.
Greg
"bbddvv" wrote:
[Quoted Text] > what is this new code? It didn't work even though i fixed the line of code
> that was on 2 lines. Ugh.
>
>
>
> "Greg Wilson" wrote:
>
> > The code you posted was originally developed by Jim Rech. This is an adaption
> > of his code from a recent post of mine. Paste to the worksheet's code module.
> > To do so, right click the worksheet's tab and select View Code to access the
> > code module. Also, ensure that the WrapText property of the merged cells is
> > set to True through Format > Cells > Alignment tab.
> >
> >
> > Private Sub Worksheet_Change(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
> >
> > With Target
> > If .MergeCells And .WrapText Then
> > Set c = Target.Cells(1, 1)
> > cWdth = c.ColumnWidth
> > Set ma = c.MergeArea
> > For Each cc In ma.Cells
> > MrgeWdth = MrgeWdth + cc.ColumnWidth
> > Next
> > Application.ScreenUpdating = False
> > 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
> > Application.ScreenUpdating = True
> > End If
> > End With
> > End Sub
> >
> > Regards,
> > Greg
|
|
You're more than welcome. We both posted at exactly the same time as I have
it. I noticed that you have quoted an old adaption of mine several times. If
I new you were going to do this I would have done a better job <g>. This is a
newer version and is IMHO better.
Greg
"Gord Dibben" wrote:
[Quoted Text] > Thanks for jumping in Greg
>
> I was going to google for your adaptation but got sidetracked.
>
> And no line wraps<g>
>
>
> Gord
>
>
> On Tue, 25 Jul 2006 12:15:01 -0700, Greg Wilson
> <GregWilson[ at ]discussions.microsoft.com> wrote:
>
> >The code you posted was originally developed by Jim Rech. This is an adaption
> >of his code from a recent post of mine. Paste to the worksheet's code module.
> >To do so, right click the worksheet's tab and select View Code to access the
> >code module. Also, ensure that the WrapText property of the merged cells is
> >set to True through Format > Cells > Alignment tab.
> >
> >
> >Private Sub Worksheet_Change(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
> >
> >With Target
> >If .MergeCells And .WrapText Then
> >Set c = Target.Cells(1, 1)
> >cWdth = c.ColumnWidth
> >Set ma = c.MergeArea
> >For Each cc In ma.Cells
> >MrgeWdth = MrgeWdth + cc.ColumnWidth
> >Next
> >Application.ScreenUpdating = False
> >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
> >Application.ScreenUpdating = True
> >End If
> >End With
> >End Sub
> >
> >Regards,
> >Greg
>
>
|
|
I like the event code because it doesn't involve hitting a button.
I can direct posters to this thread from now on.
No insult meant toward Jim Rech.
Gord Dibben MS Excel MVP
On Tue, 25 Jul 2006 14:08:02 -0700, Greg Wilson
<GregWilson[ at ]discussions.microsoft.com> wrote:
[Quoted Text] >You're more than welcome. We both posted at exactly the same time as I have
>it. I noticed that you have quoted an old adaption of mine several times. If
>I new you were going to do this I would have done a better job <g>. This is a
>newer version and is IMHO better.
>
>Greg
>
>"Gord Dibben" wrote:
>
>> Thanks for jumping in Greg
>>
>> I was going to google for your adaptation but got sidetracked.
>>
>> And no line wraps<g>
>>
>>
>> Gord
>>
>>
>> On Tue, 25 Jul 2006 12:15:01 -0700, Greg Wilson
>> <GregWilson[ at ]discussions.microsoft.com> wrote:
>>
>> >The code you posted was originally developed by Jim Rech. This is an adaption
>> >of his code from a recent post of mine. Paste to the worksheet's code module.
>> >To do so, right click the worksheet's tab and select View Code to access the
>> >code module. Also, ensure that the WrapText property of the merged cells is
>> >set to True through Format > Cells > Alignment tab.
>> >
>> >
>> >Private Sub Worksheet_Change(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
>> >
>> >With Target
>> >If .MergeCells And .WrapText Then
>> >Set c = Target.Cells(1, 1)
>> >cWdth = c.ColumnWidth
>> >Set ma = c.MergeArea
>> >For Each cc In ma.Cells
>> >MrgeWdth = MrgeWdth + cc.ColumnWidth
>> >Next
>> >Application.ScreenUpdating = False
>> >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
>> >Application.ScreenUpdating = True
>> >End If
>> >End With
>> >End Sub
>> >
>> >Regards,
>> >Greg
>>
>>
|
|
Greg, this is brilliant! I have a spreadsheet which requires a merged cell
to autofit wrapped text, and your code works a treat! Thanks so much for
this.
Cheers,
Pete
"Greg Wilson" wrote:
[Quoted Text] > The code you posted was originally developed by Jim Rech. This is an adaption
> of his code from a recent post of mine. Paste to the worksheet's code module.
> To do so, right click the worksheet's tab and select View Code to access the
> code module. Also, ensure that the WrapText property of the merged cells is
> set to True through Format > Cells > Alignment tab.
>
>
> Private Sub Worksheet_Change(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
>
> With Target
> If .MergeCells And .WrapText Then
> Set c = Target.Cells(1, 1)
> cWdth = c.ColumnWidth
> Set ma = c.MergeArea
> For Each cc In ma.Cells
> MrgeWdth = MrgeWdth + cc.ColumnWidth
> Next
> Application.ScreenUpdating = False
> 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
> Application.ScreenUpdating = True
> End If
> End With
> End Sub
>
> Regards,
> Greg
|
|
Pete, thank you for the kind words. However, as I pointed out, the code is an
adaption of mine of an old Jim Rech post that I saw years past and HE is the
author of the "brilliant" part of it. I adapted it to be event driven only
and shortened the variable names to suit my style.
Greg
"Pete at Sappi Fine Paper" wrote:
[Quoted Text] > Greg, this is brilliant! I have a spreadsheet which requires a merged cell
> to autofit wrapped text, and your code works a treat! Thanks so much for
> this.
>
> Cheers,
>
> Pete
>
> "Greg Wilson" wrote:
>
> > The code you posted was originally developed by Jim Rech. This is an adaption
> > of his code from a recent post of mine. Paste to the worksheet's code module.
> > To do so, right click the worksheet's tab and select View Code to access the
> > code module. Also, ensure that the WrapText property of the merged cells is
> > set to True through Format > Cells > Alignment tab.
> >
> >
> > Private Sub Worksheet_Change(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
> >
> > With Target
> > If .MergeCells And .WrapText Then
> > Set c = Target.Cells(1, 1)
> > cWdth = c.ColumnWidth
> > Set ma = c.MergeArea
> > For Each cc In ma.Cells
> > MrgeWdth = MrgeWdth + cc.ColumnWidth
> > Next
> > Application.ScreenUpdating = False
> > 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
> > Application.ScreenUpdating = True
> > End If
> > End With
> > End Sub
> >
> > Regards,
> > Greg
|
|
Greg,
Thanks for your help here on the message boards! Your solution to the
Merged cell autofit looks like it could save me a lot of time!
One question, is there a way I can change the macro to set the merged cells
that have been autofit to be "unprotected" after the resize? I am using this
in a worksheet that is meant for others to use a guide and thus only leave
the cells meant for user input as unprotected. After the macro runs (and
works beautifully) the resized cells are no longer unlocked.
Any ideas?
"Greg Wilson" wrote:
[Quoted Text] > The code you posted was originally developed by Jim Rech. This is an adaption
> of his code from a recent post of mine. Paste to the worksheet's code module.
> To do so, right click the worksheet's tab and select View Code to access the
> code module. Also, ensure that the WrapText property of the merged cells is
> set to True through Format > Cells > Alignment tab.
>
>
> Private Sub Worksheet_Change(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
>
> With Target
> If .MergeCells And .WrapText Then
> Set c = Target.Cells(1, 1)
> cWdth = c.ColumnWidth
> Set ma = c.MergeArea
> For Each cc In ma.Cells
> MrgeWdth = MrgeWdth + cc.ColumnWidth
> Next
> Application.ScreenUpdating = False
> 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
> Application.ScreenUpdating = True
> End If
> End With
> End Sub
>
> Regards,
> Greg
|
|
|