Free Microsoft Excel 2013 Quick Reference

Vba code to autofit merge and wrap texts cells Results

Hi -

I found this code and working just fine, when I click on a merge and a wrap text it runs to autofit that cell only. Here's my question, is it possible to modify this code that when I click on a merge and wrap texts cell it autofits not just that cells but all merge and wrap texts cells all at once? If Yes Please show me. Thank you

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
Dim ProtectStatus As Boolean

With Target
If .MergeCells And .WrapText Then
ProtectStatus = Me.ProtectContents
If ProtectStatus Then Me.Unprotect "Hvdaz"
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
On Error Resume 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
On Error GoTo 0
If ProtectStatus Then Me.Protect "Hvdaz"
Application.ScreenUpdating = False
End If
End With
End Sub


I've researched this for 2 days with no luck. I'm not very good at VBA, but I have a document that has multiple merged rows that I need to autofit. I found a bunch of other code on the net but cannot get anything to work. I know it's not good practice to merge cells, but this document really has no other good way to do it. Can someone please help me learn?

Basically as it is typed below, I can go to Tool/Macro/Macro/Run and the screen flashes for a second, but nothing happens.

I can change the code in Sheet 1 from Worksheet_Change to Worksheet_SelectionChange and I get "Application-defined or Object defined Error". The debugger goes to "ActiveCell.Offset(-1, 0).Select". I don't know what to do from there.

Below is the code I have in sheet 1

Private Sub Worksheet_Change(ByVal Target As Range)
Call AutoFitMergedCellRowHeight
End Sub

Below is the code I have so far in Module 1

''Simulates row height autofit for a merged cell if the active cell..
'' is merged.
'' has Wrap Text set.
'' includes only 1 row.
''Unlike real autosizing the macro only increases row height
'' (if needed). It does not reduce row height because another
'' merged cell on the same row may needed a greater height
'' than the active cell.
Sub AutoFitMergedCellRowHeight()
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
ActiveCell.Offset(-1, 0).Select
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
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

Private Sub Worksheet_Change(ByVal Target As Range)
AutoFitMergedCellRowHeight
End Sub

Hi,
I ran a search in the excel help forum and found similar posts but all suggestions I found referred to writing a vba code such as the one below:


	VB:
	
 Format() 
    Rows(x).entirerow.autofit 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
I have tried a vba code such as the one above but the issue persists.

I have a worksheet with merged cells [horizontal]; each cell is also formatted to warp text.
The issue is that the row size or cell size [vertical] does not adjust when the user types more text than what the cell size can handle.

would anyone have a suggestion?
cheers
Simon

Hello, Thanks in advance for your help.

Before I even ask my question, I am far from being a programer and don't
really even know enough to be dangerous. I am developing a template for a
group of 40 sales reps which will be used to track large accounts. The
template requires the use of merged cells which will need to be able to use
word wrap. I followed previous advice and use the following code from Jim
Rech:
''Simulates row height autofit for a merged cell if the active cell..
'' is merged.
'' has Wrap Text set.
'' includes only 1 row.
''Unlike real autosizing the macro only increases row height
'' (if needed). It does not reduce row height because another
'' merged cell on the same row may needed a greater height
'' than the active cell.
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
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

This works fine, just need it to be automatic. So I added this to the
worksheet:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
AutoFitMergedCellRowHeight
End Sub

This mostly works. When I enter text in a merged cell which will require
wrap then press enter, it does not automatically wrap. But when I go back
and click on the cell, it wraps. What do I need to do so I don't have to go
back and click on the cell?

Thanks,
Steve

Hi All,

I require some help in writing a code in VBA that adjusts the row height to show all the text which is in the merged cells of different rows.

Some rows contains a merged cell that extends from column F to S, that has alignment formatting of Horizontal: Left Indent, Vertical: Top, Wrapped=True

These merged cells contain fairly lengthy text, so with the settings as above, i just need to adjust the row heights of each to show all the text. This becomes quite a task considering there are about 50 rows on 5 different sheets, so I want a macro to do it.

so far i have only been able to come up with a code that performs the task on one merged cell i.e. when its the active cell

Sub AutoFitRowHeightt()
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
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
what i need is for the macro to do is:

1)search through the range A3:A100 looking for any cells that contain text or just <>"".
2)for each cell that it finds, i want it to adjust the row height so that all the text in the cell is shown.

I am attempting to develop a work around and to date have the below:

Sub findString()
    Dim sFind  As String
    Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
    Dim CurrCell As Range
    Dim ActiveCellWidth As Single, PossNewRowHeight As Single
    sFind = Application.InputBox("A1:A250")
    If sFind <> "" Then
        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
                    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 If
End Sub
As may be apparent tomost of you, the above work around is incorrect. Any help modifying the first code in order to perform the two noted tasks would be greatly appreciated.

Best,

Joe


No luck finding an answer? You could always try Google.