обернуть текст листа объединенными и не объединенными ячейками

Question

У меня есть лист с некоторыми ячейками, объединенными в ряды, а некоторые нет. Я хочу обернуть все ячейки, и если строки содержат объединенные ячейки, установите высоту строк на максимальную высоту всех ячеек

. В файле excel вы можете найти лист, с которым я работаю , что я хочу иметь, макрос Excel, который я написал, что я получаю с этим макросом. Я также поместил их здесь.

Вот что у меня есть: (столбец D - скрытый столбец)

Это то, что я хочу иметь: ( остальную часть листа см. в прикрепленном файле excel)

Я написал макрос VBA excel для этой работы, но не повезло.

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.

Надеюсь, я понял вопрос. Пожалуйста, помогите, я работаю над этим уже несколько дней: (* ​​1027 *

Cheers, Eda

Answer 1

Идея:

1. Начните с обтекания всех ячеек и использования автоподбора для всех строк. Таким образом, Excel автоматически установит высоту строки правильно.
2. L oop через строки, объединяющие ячейки и делящие высоту строки с обернутым текстом по строкам, которые будут объединены.

Вот как:

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