Tự động fit chiều cao dòng của ô đã MERGE trong excel

Sub AutoFitMerge()
     Dim sDiachi As String
    Range("A1").Select
    sDiachi = Selection.SpecialCells(xlCellTypeLastCell).Address
    sDiachi = Replace(sDiachi , "$", "")
    Range("A1:" & sDiachi).Select
    For Each rCell In Selection
          If rCell.MergeCells Then
               AutoFitMergedCellRowHeight
          End If
    Next
    Range("A1").Select
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim NewRwH As Single
Dim cWd As Single, MrgeWd As Single
Dim c As Object, cc As Object
Dim ma As Object
Application.ScreenUpdating = False
With Target
If .MergeCells And .WrapText Then
cWd = .ColumnWidth
Set ma = .MergeArea
For Each cc In ma.Cells
MrgeWd = MrgeWd + cc.ColumnWidth
Next
ma.MergeCells = False
.ColumnWidth = MrgeWd
.EntireRow.AutoFit
NewRwH = .RowHeight
With ma
    .MergeCells = True
    .RowHeight = NewRwH
End With
End If
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Application.ScreenUpdating = True
End Sub

Sub AutoFitMergedCellRowHeight()
     Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
     Dim CurrCell As Range
     Dim ActiveCellWidth As Single, PossNewRowHeight As Single
     Dim iX As Integer
     ActiveCell.WrapText = True
     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
                     iX = iX + 1
                 Next
                 MergedCellRgWidth = MergedCellRgWidth + (iX - 1) * 0.71
                 .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

Sub AutoFitMerge()
     Dim lDong As Long
     Dim i As Integer
     Dim sCelldau As String
     Dim rCell As Range
     Dim NewRwH As Single, cWd As Single, MrgeWd As Single
     With Application
          .ScreenUpdating = False  'Tam dung cap nhat man hinh
          .Calculation = xlCalculationManual  'Tat cap nhat tinh toan
          .EnableEvents = False
          .DisplayAlerts = False
          .Cursor = xlWait
          .EnableCancelKey = xlErrorHandler
     End With
     lDong = ActiveCell.Row + Selection.Rows.Count
     sCelldau = ActiveCell.Address
     ActiveCell.Select
     Do Until ActiveCell.Row = lDong
          If ActiveCell.MergeCells Then
               With ActiveCell
                    .WrapText = True
                    If i = 0 Then
                         'Lay ColumnWidth cua cell dau va Tinh Tong ColumnWidth
                         For Each rCell In Selection
                              i = i + 1
                              'Lay ColumnWidth cua cell dau
                              If i = 1 Then cWd = rCell.ColumnWidth
                              'Tinh Tong ColumnWidth
                              MrgeWd = MrgeWd + rCell.ColumnWidth
                         Next
                    End If
                    Selection.MergeCells = False
                    .ColumnWidth = MrgeWd
                    .EntireRow.AutoFit
                    NewRwH = .RowHeight
                    'Tra lai ColumnWidth cua cell dau
                    .ColumnWidth = cWd
                    'MergeCells va lay Chieu cao Dong
                    With Selection
                        .MergeCells = True
                        .RowHeight = NewRwH
                    End With
               End With
          End If
          ActiveCell.Offset(1).Select
     Loop
     With Application
          .ScreenUpdating = True   'Cap nhat man hinh
          .Calculation = xlCalculationAutomatic       'Cap nhat tinh toan
          .EnableEvents = True
          .DisplayAlerts = True
          .Cursor = xlDefault
          .EnableCancelKey = xlInterrupt
     End With
     Range(sCelldau).Select
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim NewRwH As Single
    Dim cWd As Single, MrgeWd As Single
    Dim c As Object, cc As Object
    Dim ma As Object
    With Target
        'Qui dinh ap dung cho Dong va Cot
        If .Column <> 2 Then Exit Sub
        If .Row = 15 Or .Row = 39 Then
            If .MergeCells And .WrapText Then
                Application.ScreenUpdating = False
                cWd = .ColumnWidth
                Set ma = .MergeArea
                For Each cc In ma.Cells
                    MrgeWd = MrgeWd + cc.ColumnWidth
                Next
                ma.MergeCells = False
                .ColumnWidth = MrgeWd
                .EntireRow.AutoFit
                NewRwH = .RowHeight
                .ColumnWidth = cWd
                With ma
                    .MergeCells = True
                    .RowHeight = NewRwH
                    .VerticalAlignment = xlCenter
                    .HorizontalAlignment = xlJustify
                End With
                Application.ScreenUpdating = True
            End If
        End If
    End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
     If Target.Address <> "$F$2" Then Exit Sub
     With ActiveSheet
          Range("A12").Select
          AutoFit_MergeCell
          Range("A21").Select
          AutoFit_MergeCell
          '.PrintOut
     End With
End Sub

Sub AutoFit_MergeCell()
     Dim NewRwH As Single
     Dim cWd As Single, MrgeWd As Single
     Dim c As Object, cc As Object
     Dim ma As Object
     With ActiveCell
          If .MergeCells And .WrapText Then
               Application.ScreenUpdating = False
               cWd = .ColumnWidth
               Set ma = .MergeArea
               For Each cc In ma.Cells
                    MrgeWd = MrgeWd + cc.ColumnWidth
               Next
               ma.MergeCells = False
               .ColumnWidth = MrgeWd
               .EntireRow.AutoFit
               NewRwH = .RowHeight
               .ColumnWidth = cWd
               With ma
                    .MergeCells = True
                    .RowHeight = NewRwH
                    .VerticalAlignment = xlCenter
                    .HorizontalAlignment = xlJustify
               End With
               Application.ScreenUpdating = True
          End If
     End With
End Sub