Autofit rækker (blandet flettede og ikke flettede celler)

Hej.

jeg har forsøgt mig med en VBA kode til autotilpas af højde på rækker i et excel ark.
Arket er et spørgeskema, hvor der er en god blanding af enkelt celler og flettede celler.

Jeg har umiddelbart fået lavet en kode til autotilpasning af højde, men synes ikke det fungerer optimalt.

Det er som om man skal bruge piletasterne op og ned et par gange før det slår igennem.
Det skulle egentlig bare ske når man skriver i en celle og trykker enter.

Jeg håber i kan hjælpe.

Koden ser sådan ud:

Private Sub Worksheet_selectionChange(ByVal Target As Excel.Range)
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