Excelマクロはセルの高さを調整します

Question

スクリプトはデータをExcelテンプレートに移動します。関連情報のコードワードが変更されます。

TPLNRとAUFNRが満たされていれば、すべて正常に動作します。セルの高さは2行です。しかし、私が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の後に行を取得して意図したようにするにはどうすればよいですか？ 1倍の高さ。

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