Excel макрос корректирует высоту ячейки

Question

Мой скрипт перемещает данные в Excel. Кодовое слово изменено для соответствующей информации.

Все работает хорошо, если TPLNR и AUFNR заполнены. Ячейка имеет две строки по высоте. Но если я оставлю AUFNR или TPLNR, то высота ячейки не корректируется. Это макрос, используемый для заполнения и настройки каждой строки в таблице.

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 

Что я могу сделать, чтобы получить строки после 12, чтобы они выглядели так, как планировалось? С высотой 1x.

Answer 1

Создание рядов равного размера - довольно стандартная задача VBA.

Просто попробуйте отложить эту логику от вашего кода. Единственное, что вам нужно знать, это начальная строка, конечная строка и размер. Таким образом, вы можете сделать это достаточно хорошо. В приведенном ниже коде измените параметры Call AllRowsAreEqual(4, 10, 35), чтобы они работали для вас.

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