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 

의도 한 것처럼 보이게하려면 어떻게해야합니까? 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