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任务。

试着把这个逻辑远离你的代码。你应该知道的唯一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