Excel macro adjust cell height - vba

Question

My script moves data to excel template. Codewords is changed for relevant info.
All works well if TPLNR and AUFNR is filled. The cell is two rows in height. But if i leave AUFNR or TPLNR blank - cell height not ajusted. This is macro used to fill and adjust every row in table.
Sub Mac1()
'
' Mac1
'
Dim i As Integer
i = 12
'
Do While Range("L" & i).Value <> "THE END"
If Range("L" & i).Value = "M" Then
...
ElseIf Range("L" & i).Value = "T" Then
Range("A" & i & ":D" & i).Select
With Selection
.HorizontalAlignment = xlCenter
.Orientation = 0
.WrapText = True
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.Merge
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Selection.Font.Italic = True
End If
i = i + 1
Loop
Call AutoFitMergedCellRowHeight
Columns("L:L").Select
Selection.Delete Shift:=xlToLeft
End Sub
Sub AutoFitMergedCellRowHeight()
Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
Dim StartCell As Range, c As Range, MergeRng As Range, Cell As Range
Dim a() As String, isect As Range, i
'Take a note of current active cell
Set StartCell = ActiveCell
'Create an array of merged cell addresses that have wrapped text
For Each c In ActiveSheet.UsedRange
If c.MergeCells Then
With c.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
If MergeRng Is Nothing Then
Set MergeRng = c.MergeArea
ReDim a(0)
a(0) = c.MergeArea.Address
Else
Set isect = Intersect(c, MergeRng)
If isect Is Nothing Then
Set MergeRng = Union(MergeRng, c.MergeArea)
ReDim Preserve a(UBound(a) + 1)
a(UBound(a)) = c.MergeArea.Address
End If
End If
End If
End With
End If
Next c
Application.ScreenUpdating = False
'Loop thru merged cells
For i = 0 To UBound(a)
Range(a(i)).Select
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
MergedCellRgWidth = 0
Next i
StartCell.Select
Application.ScreenUpdating = True
'Clean up
Set CurrCell = Nothing
Set StartCell = Nothing
Set c = Nothing
Set MergeRng = Nothing
Set Cell = Nothing
End Sub
What could i do to get rows after 12 to look like it intended to? With 1x height.

Answer 1

Making the rows equal size is quite a standard VBA task.
Just try to put this logic away from your code. The only 3 things you should know is the starting row, the ending row and the size. Thus, you may be able to do it quite well. In the code below change the parameters of Call AllRowsAreEqual(4, 10, 35) in order to make it work for you.
Option Explicit
Sub AllRowsAreEqual(lngStartRow As Long, lngEndRow As Long, lngSize)
Dim lngCounter As Long
For lngCounter = lngStartRow To lngEndRow
Cells(lngCounter, 1).RowHeight = lngSize
'Debug.Print lngCounter
Next lngCounter
End Sub
Public Sub Main()
Call AllRowsAreEqual(4, 10, 35)
End Sub