Excelmacros调整单元格高度
我的脚本将数据移动到excel模板。 代码字更改为相关信息。 
如果TPLNR和AUFNR被填满，一切运作良好。 这个单元格是两排高度。 但是，如果我离开AUFNR或TPLNR空白 – 单元格高度不调整。 这是macros用于填充和调整表中的每一行。
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高度。 
使行的大小相当是一个标准的VBA任务。
试着把这个逻辑远离你的代码。 只有3件事你应该知道的是起始行，结束行和大小。 因此，你可能会做得很好。 在下面的代码中，更改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