合并不同范围内的单元格

Question

我有以下内容：



我期待以下内容：

我正在使用此代码：

Sub merge_cells()

Application.DisplayAlerts = False

Dim r As Integer
Dim mRng As Range
Dim rngArray(1 To 4) As Range
r = Range("A65536").End(xlUp).Row

For myRow = r To 2 Step -1

    If Range("A" & myRow).Value = Range("A" & (myRow - 1)).Value Then

        For cRow = (myRow - 1) To 1 Step -1

            If Range("A" & myRow).Value <> Range("A" & cRow).Value Then

                Set rngArray(1) = Range("A" & myRow & ":A" & (cRow + 0))
                Set rngArray(2) = Range("B" & myRow & ":B" & (cRow + 0))
                Set rngArray(3) = Range("C" & myRow & ":C" & (cRow + 0))
                Set rngArray(4) = Range("D" & myRow & ":D" & (cRow + 0))

                For i = 1 To 4
                    Set mRng = rngArray(i)
                    mRng.Merge
                    With mRng
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        .WrapText = False
                        .Orientation = 90
                        .AddIndent = False
                        .IndentLevel = 0
                        .ShrinkToFit = False
                        .ReadingOrder = xlContext
                        .MergeCells = True
                    End With

                Next i

                myRow = cRow + 2
                Exit For
            End If
        Next cRow
    End If
Next myRow

Application.DisplayAlerts = True

End Sub

我得到的是：

问题： 如何实现这一目标？

实际上，在我的原始数据中，前三列从第3行开始每隔88行有一个数据，而列D应该每四行合并一次。

Answer 1

您的代码不以任何方式区分不同的列。如果您知道要合并多少行，则只需搜索单元格，然后根据列号进行合并。下面是一种这样的方法，它使用一对数组来跟踪要合并的行数以及要应用的格式。

您需要更改数组定义中的行数。听起来像你想要的（87,87,87,3）基于你的编辑。我做了（11,11,11,3）来匹配你的例子。这是对您的代码的真正修复;它使用Column数字来确定要合并的行数。

我还在电子表格中输入了一些值，并使用SpecialCells仅获取具有值的单元格。如果您的数据符合您的示例，则可以正常使用。

编辑包括每个OP请求首先取消合并单元格。

Sub MergeAllBasedOnColumn()

    Dim rng_cell As Range
    Dim arr_rows As Variant
    Dim arr_vert_format As Variant

    'change these to the actual number of rows
    'one number for each column A, B, C, D
    arr_rows = Array(11, 11, 11, 3)

    'change these if the formatting is different than example
    arr_vert_format = Array(True, True, True, False)

    'unmerge previously merged cells
    Cells.UnMerge

    'get the range of all cells, mine are all values
    For Each rng_cell In Range("A:D").SpecialCells(xlCellTypeConstants)

        'ignore the header row
        If rng_cell.Row > 2 Then

            'use column to get offset count
            Dim rng_merge As Range
            Set rng_merge = Range(rng_cell, rng_cell.Offset(arr_rows(rng_cell.Column - 1)))

            'merge cells
            rng_merge.Merge

            'apply formatting
            If arr_vert_format(rng_cell.Column - 1) Then
                'format for the rotated text (columns A:C)
                With rng_merge
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        .WrapText = False
                        .Orientation = 90
                        .AddIndent = False
                        .IndentLevel = 0
                        .ShrinkToFit = False
                        .ReadingOrder = xlContext
                End With
            Else
                'format for the other cells (column D)
                With rng_merge
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        .WrapText = False
                End With
            End If
        End If
    Next rng_cell
End Sub

<强>之前

<强>后