Autofit Worksheet

Question

I’ve a worksheet in a workbook containing over 400 rows, 8 columns and 160 merged ranges and I messed up its appearance. I searched the internet for VBA Autofit Merged Cells. None of the URLs are much use. The macro on this website is on the right track but: -
1) I’d have to manually identify and type in the 160 merged ranges.
I added a search for merged cell ranges.
2) It uses row one to do merged cell calculations (Cell ZZ1). I use a much larger font on cell A1 (Title) which results in errors calculating required merged autofit height.
I use a cell 1 column right and 1 row below data. (Ctrl+Shift+End, doesn’t find this cell)
3) It recalculates all merged cells so it reduced the height of two rows containing both merged and normal cells making the normal cells unreadable.
I alter row height only when the required merged height exceeds existing height.
4) The method for copying data in merged ranges to cell ZZ1 is incorrect, based only upon text in the merged range but not taking account of differing font sizes in various merged cells.
I corrected the copying method.
5) The macro is slow: about 15+ seconds on my worksheet.
Switching off screen refresh and back on at end of macro reduces this to 2 seconds.

I managed to find another irritating fault. Autofit the worksheet (before correcting the merged ranges) and it distorted several rows. Some “Normal” cells, set to wrapped, had their height increased and were appearing as a line (or two lines) of text with a blank row below the text. Internet search indicated that it’s caused by Excel altering the display to accommodate printer fonts. Found a “work around”, I added to the macro:
Increase column widths by a small percentage.
Autofit all rows on worksheet.
Carry out corrections to row height to accommodate merged ranges.
Revert column width to original sizes.
That fixed it, blank rows are now no longer appearing!

Thought that all was now correct but I then discovered a further problem. If I close the workbook and reopen it again, the blank rows are back again. Looked at File/Options and I have searched the Internet for a method of preventing the workbook updating the screen display on closing/opening the workbook without success. I had to add Private Sub Workbook_Open() on the “ThisWorkbook” tab with a call to run the Macro when the workbook is opened.

Option Explicit

Sub Look4Merged()
Dim WSN As String 'Worksheet Name
Dim sht As Worksheet 'Used by "Set"
Dim LastRow As Long 'Last row in all columns with data
Dim LastRowCC As Long 'Last row in current column with data
Dim LastColumn As Integer 'Number of last column in all rows with data
Dim CurrCol As Integer 'Nummber of current column
Dim Letter As String 'Convert CurrCol number to string
Dim ILetter As String 'Index colum one to right of Last Column
Dim ICell As String 'Cell one column right & one row down frpm data area. Used to calculate required merged height
Dim CRow As Long 'Current Row Number
Dim TwN As Long 'Error handling
Dim TwD As String 'Error handling
Dim Mgd As Boolean 'True/False test if cell is merged
Dim MgdCellAddr As String 'Contains merged range as a string
Dim MgdCellStart As String 'Start letter of merged Cell range Used e.g. inspecting Column B for merged cells, ignore any merged cells starting in Column A extending to column B (already assessed)
Dim MgdCellStart1 As String 'used to calculate MgdCellStart
Dim MgdCellStart2 As String 'used to calculate MgdCellStart
Dim OldHeight As Single 'Existing height of all rows in merged range
Dim P1 As Integer 'Loop count/pointer
Dim OldWidth As Single 'Existing width of cells in merged range
Dim NewHeight As Single 'Required height of all rows in merged range. Update individual rows proportionately if it exceeds OldHeight
Dim C1 As Integer 'Loop Column count
Dim R1 As Long 'Loop Row count/pointer
Dim Tweak As Single 'Small increase in column width to overcome blank row problem
Dim oRange As Range
On Error GoTo TomsHandler

Application.ScreenUpdating = False 'MUCH faster 15 secs if screen updted only 2 seconds switched off.
Tweak = 1.04 'Increase column width by 4% before Autofit all rows.
WSN = ActiveSheet.Name
Columns("A:A").EntireRow.Hidden = False

'Find Last Active Row & Column in entire Worksheet with Data
With ActiveSheet.UsedRange
LastColumn = Range(Range("A1"), Cells(Rows.Count, Columns.Count)).Find(What:="*", LookIn:=xlValues, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
LastRow = Range(Range("A1"), Cells(Rows.Count, Columns.Count)).Find(What:="*", LookIn:=xlValues, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End With
CurrCol = LastColumn + 1 'i.e. to right of last column
If CurrCol < 27 Then
ILetter = Chr$(CurrCol + 64) 'Index Column
Else
ILetter = Chr$(Int((CurrCol - 1) / 26) + 64)
ILetter = ILetter & Chr$(CurrCol - Int((CurrCol - 1) / 26) * 26 + 64) 'Index Column if double digit.haven't bothered with triple letter
End If

'Icell is located right and below data. Cell is used to calculate height required to fit merged range
ICell = ILetter & LastRow + 1

'Increase column width by small amount to cure blank row wrapping bug.
Range("A" & LastRow + 1).Select
For C1 = 1 To LastColumn
ActiveCell.ColumnWidth = ActiveCell.ColumnWidth * Tweak 'increase column width by small amount to cure bug
ActiveCell.Offset(0, 1).Range("A1").Select ' move one cell right
Next

'Autofit Rows (ignores merged rows) with column width 4% extra to prevent blank rows bug on some wrapping Rows
Cells.Select
Selection.Rows.AutoFit
Set sht = Worksheets(WSN) 'needed to find Last entry in column with data

For CurrCol = 1 To LastColumn
'convert current column number to alpha (either single or double letter)
If CurrCol < 27 Then
Letter = Chr$(CurrCol + 64)
Else
Letter = Chr$(Int((CurrCol - 1) / 26) + 64)
Letter = Letter & Chr$(CurrCol - Int((CurrCol - 1) / 26) * 26 + 64)
End If
LastRowCC = sht.Cells(sht.Rows.Count, Letter).End(xlUp).Row 'find last row in current column

For CRow = 1 To LastRowCC
Range(Letter & CRow).Select
Mgd = ActiveCell.MergeCells 'Is cell in merged range
If Mgd = True Then 'If True, then it is
'What's the merged range address? extract single/double digit for start of range
MgdCellAddr = ActiveCell.MergeArea.Address
MgdCellStart1 = Mid(MgdCellAddr, 2, 1)
MgdCellStart2 = Mid(MgdCellAddr, 3, 1)
If MgdCellStart2 = "$" Then
MgdCellStart = MgdCellStart1
Else
MgdCellStart = MgdCellStart1 & MgdCellStart2
End If
If MgdCellStart = Letter Then 'Is Merged cell first column equal to the current column
With Sheets(WSN)
OldWidth = 0
Set oRange = Range(MgdCellAddr) 'set oRange to Merged Range detected
For C1 = 1 To oRange.Columns.Count
OldWidth = OldWidth + .Cells(1, oRange.Column + C1 - 1).ColumnWidth 'Accumulate column widths for range of cells (with 4% added)
Next
OldHeight = 0
For R1 = 1 To oRange.Rows.Count
OldHeight = OldHeight + .Cells(CRow, oRange.Row + R1 - 1).RowHeight 'Accumulate existing row height for range of cells
Next
oRange.MergeCells = False
.Range(Letter & CRow).Copy Destination:=Range(ICell) 'Copies text AND font size, not values only
.Range(ICell).WrapText = True 'wrap ICell
.Columns(ILetter).ColumnWidth = OldWidth 'change width of column containing ICell to mimic existing range
.Rows(LastRow + 1).EntireRow.AutoFit 'Autofit the ICell row, ready to measure the required merged height
oRange.MergeCells = True 'Reset the merged Range back to merged
oRange.WrapText = True 'and wrapping
'Measure required height for merged range
NewHeight = .Rows(LastRow + 1).RowHeight
'Does the New required height exceed the Old existing height
If NewHeight > OldHeight Then
For R1 = CRow To CRow + oRange.Rows.Count - 1
'Increase each row in range pro rata
Range(ILetter & R1).RowHeight = Range(ILetter & R1).RowHeight * NewHeight / OldHeight
Next
Else
'sufficient room in merged cell
End If
CRow = CRow + oRange.Rows.Count - 1 'else on multirow range, will drop down to 2nd row of range and repeat calculation when arriving at "Next"
.Range(ICell).Clear 'Zap ICell ready for next calculation
.Range(ICell).ColumnWidth = 8.1 'Tidy up column width
End With
End If
End If
Next
Next

'Reset column width removing 4% added (needed to cure wrap error)
Range("A" & LastRow + 1).Select
For C1 = 1 To LastColumn
ActiveCell.ColumnWidth = ActiveCell.ColumnWidth / Tweak 'reduce column width to original
ActiveCell.Offset(0, 1).Range("A1").Select ' one cell right
Next
Range("A1").Select

Application.ScreenUpdating = True 'switch updating back on
Exit Sub

TomsHandler:
Application.ScreenUpdating = True 'switch updating back on
TwN = Err.Number
TwD = Err.Description
MsgBox "Need to handle error " & TwN & " " & TwD
Stop
Resume
End Sub

Is it possible to prevent Excel from changing the screen display appearance on closing/reopening the workbook?

Trang tính tự động điều chỉnh