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

Excel宏调整单元格高度

1 个答案: