Option Explicit
Sub AutoFitRowHeight()
Dim fRow As Long, lRow As Long, NumberRow As Long, fR2 As Long
Dim i As Long, ik As Long
Dim DeltaRowHei As Double, fCurr As Long, fP As Long
Dim m As Double, tmp As Double, MrgeWdth As Double
Dim col As Byte, Scol As Byte, j As Byte, n As Byte, k As Byte
Dim Arr As Variant
Application.ScreenUpdating = False
i = Range("B65000").End(xlUp).Row
If i < 7 Then Exit Sub 'Khong co dong fit
Arr = Range("B1:B" & i).Value
For i = 7 To UBound(Arr)
If UCase(Arr(i, 1)) = "X" Then
lRow = i
If fRow = 0 Then fRow = i
End If
If UCase(Arr(i, 1)) = "FR" Then fR2 = i
Next i
If lRow = 0 Then Exit Sub 'Khong co dong fit
ReDim Arr(1 To lRow - fRow + 2, 1 To 10)
With CreateObject("scripting.dictionary")
For i = fRow To lRow
If Range("B" & i).EntireRow.Hidden = False And Range("B" & i) <> Empty Then
n = 0
For col = 3 To 27
If Cells(i, col) <> Empty And Cells(i, col).MergeCells Then
Scol = Cells(i, col).MergeArea.Columns.Count
MrgeWdth = 0
For j = 1 To Scol
MrgeWdth = MrgeWdth + Cells(i, col + j - 1).ColumnWidth + 0.75
Next j
If Not .exists(MrgeWdth) Then
k = k + 1
.Add MrgeWdth, k
Arr(UBound(Arr), k) = MrgeWdth
End If
n = n + 1
ik = i - fRow + 1
Arr(ik, .Item(MrgeWdth)) = Cells(i, col).Value
Cells(i, 29 + n).Font.Size = Cells(i, col).Font.Size
If Cells(i, col).Font.Bold = True Then Cells(i, 29 + n).Font.Bold = True
If Cells(i, col).Font.Italic = True Then Cells(i, 29 + n).Font.Italic = True
If Cells(i, col).Font.Underline = xlUnderlineStyleSingle Then Cells(i, 29 + n).Font.Underline = xlUnderlineStyleSingle
col = col + Scol - 1
End If
Next col
End If
Next i
End With
Range("AD" & fRow).Resize(UBound(Arr) - 1, k) = Arr
Range("AD" & fRow).Resize(UBound(Arr) - 1, k).WrapText = True
For j = 1 To k
Cells(1, 29 + j).ColumnWidth = Arr(UBound(Arr), j)
Next j
For i = 1 To UBound(Arr) - 1
m = 0
For j = 1 To k
If Arr(i, j) <> Empty Then
Cells(fRow + i - 1, 29 + j).EntireRow.AutoFit
tmp = Cells(fRow + i - 1, 29 + j).RowHeight
If m < tmp Then m = tmp
End If
Next j
If m Then Cells(fRow + i - 1, 3).RowHeight = m
Next i
Range("AD" & fRow).Resize(UBound(Arr) - 1, k).Clear
'Dong dau khi sang trang moi
ActiveWindow.View = xlPageBreakPreview
fP = ActiveSheet.HPageBreaks.Count
fCurr = ActiveSheet.HPageBreaks(fP).Location.Row
If fCurr < Range("D65000").End(xlUp).Row Then
NumberRow = fR2 - fRow
If fR2 = 0 Then fR2 = lRow
If fCurr > fR2 Then
DeltaRowHei = (Range("E" & lRow & ":E" & fCurr).Height - Range("E" & lRow & ":E" & fR2).Height) / NumberRow
For i = fRow To lRow
If Range("C" & i).EntireRow.Hidden = False Then _
Range("C" & i).RowHeight = Range("C" & i).RowHeight + DeltaRowHei + 16.5 / 5
Next i
End If
End If
ActiveWindow.View = xlNormalView
Application.ScreenUpdating = True
End Sub
