excel - 用合并和未合并的单元格换行工作表的文本

Question

我有一张表格，其中一些单元格合并成行，而有些则没有。我想包装所有单元格，如果行包含合并的单元格，请将行高设置为所有单元格高度的最大值

在 excel file ，你可以找到我正在使用的工作表，我想要的，我写的 excel 宏，我用那个宏得到了什么。我也把它们放在这里。

这就是我所拥有的:(D 列是隐藏列)


这就是我想要的:(对于工作表的其余部分，请参阅附加的 excel 文件)


我写了一个 excel VBA 宏来完成这项工作，但没有运气。

Sub MergeCells2()

Application.DisplayAlerts = False
Dim allRange As Range
Dim xCell As Range
On Error Resume Next
Dim i_row As Integer
Dim nRowsToMerge As Integer
Dim rangeToMerge As Range

Worksheets("What I have").Activate

LastCol = ActiveSheet.Range("a1").End(xlToRight).Column
LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, LastCol).End(xlUp).Row
Set allRange = Application.Range("a1", ActiveSheet.Cells(LastRow, LastCol))
allRange.WrapText = True


If allRange Is Nothing Then Exit Sub
nRowsToMerge = 1
Set heightToSet = Range("A2").RowHeight

For i_row = 2 To LastRow
    Set i_rowRange = allRange.Rows(i_row - 1)

    If (allRange.Cells(i_row, 1) = "") Then
        nRowsToMerge = nRowsToMerge + 1

    ElseIf nRowsToMerge = 1 Then
        heightToSet = i_rowRange.RowHeight

    Else
        Set rangeToMerge = ActiveSheet.Range(ActiveSheet.Cells(i_row - nRowsToMerge, 1), ActiveSheet.Cells(i_row - 1, LastCol))

        For Each xCell In rangeToMerge
            cellrow = xCell.Row
            If (rangeToMerge.Cells(cellrow, 1) = "") Then
                If xCell.Value = "" Then
                    Range(xCell, xCell.Offset(-1, 0)).Merge
                End If
            End If
        Next

        rangeToMerge.RowHeight = heightToSet
        heightToSet = i_rowRange.RowHeight
        nRowsToMerge = 1

    End If
Next i_row
End Sub

这就是我得到的:


我不知道它有什么问题，我不得不说我对 VBA 编程了解不多。

我希望我的问题很清楚。
请帮忙，我已经为此工作了好几天:(

干杯，
江田

Answer 1

想法:

首先包装所有单元格，并对所有行使用 AutoFit。这样 Excel 将自动正确设置行高。

遍历合并单元格的行，并将行的高度与要合并的行上的换行文本分开。

方法如下:

Sub NewMerger()

    Dim r As Long, rMax As Long, re As Long, cMax As Long, c As Long, n As Long, h As Single, mr As Long

    Application.DisplayAlerts = False

    'Create a copy of the input
    Sheets("What I have").Copy After:=Sheets(Sheets.Count)
    On Error Resume Next
    Sheets("New Result").Delete
    ActiveSheet.Name = "New Result"

    'merge and use autofit to get the ideal row height
    Cells().WrapText = True
    Rows.AutoFit

    'get max row and column
    cMax = Cells(1, 1).End(xlToRight).Column
    rMax = Cells(Rows.Count, 1).End(xlUp).Row

    'loop through rows, bottom to top
    For r = rMax To 2 Step -1
        If Cells(r, 1).Value = "" Then
            If re = 0 Then re = r 'If we don't have an end row, we do now!
        ElseIf re > 0 Then 'If re has an end row and the current row is not empty (AKA start row)
            h = Rows(r).RowHeight 'Get the row height of the start row
            n = re - r + 1 'calculate the number of rows
            If n > 0 Then Rows(r & ":" & re).RowHeight = h / n 'devide the row hight over all rows
            For c = 1 To cMax 'And merge
                For mr = re To r Step -1 'Merge only empty cells 
                    If Cells(mr, c).Value = "" Then 
                        Range(Cells(mr, c), Cells(mr - 1, c)).MergeCells = True 
                    End If 
                Next
            Next
            re = 0 'We don't have an end row now
        End If
    Next
    Application.DisplayAlerts = True
End Sub