Sub RowAutoFit()
Application.ScreenUpdating = False
lRow = Cells(Rows.Count, 2).End(xlUp).Row
For I = 1 To lRow
    Rows(I).EntireRow.AutoFit
Next
Application.ScreenUpdating = True
End Sub

Public Sub TextToHeightFit()
    Dim textShape As Shape, cellCount As Long
    Dim pSheet As Worksheet, cellHeight As Single
    Set pSheet = ActiveSheet
    Set textShape = pSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, ActiveCell.Left, ActiveCell.Top, ActiveCell.Width, ActiveCell.Height)
    With textShape.TextFrame2
        .AutoSize = msoAutoSizeShapeToFitText
        .TextRange.Text = ActiveCell.Value
    End With
    cellCount = Application.WorksheetFunction.RoundUp(textShape.Height / ActiveCell.Height, 0)
    If cellCount > 1 Then
        cellHeight = textShape.Height / cellCount
        ActiveCell.Resize(cellCount - 1, 1).EntireRow.Insert Shift:=xlDown
        ActiveCell.Resize(cellCount, 1).Merge
        ActiveCell.Resize(cellCount, 1).EntireRow.RowHeight = cellHeight
    End If
    textShape.Delete
End Sub