VBA Excel - 根据A列合并合并B列中的单元格

Question

我有一个合并 A 列中连续单元格的例程。我需要合并 B 列中顺序匹配的单元格，但不合并合并的 A 列单元格的行边界。我对 A 列的合并按预期工作。

但是，如果 B 列中的值具有从合并的 A 单元格旁边开始并继续到下一个单元格的连续值，它们将跨越边界合并。我如何根据已合并的 A 单元格合并顺序匹配的 B 单元格？

以下是我的代码当前如何合并 A 列合并单元格的行边界：

这是我打算让它看起来的样子：

我当前的代码：

Sub MergeV()
    ' Merge Administration and Category where sequentional matching rows exist

    ' Turn off screen updating
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim Current As Worksheet
    Dim lrow As Long

    For Each Current In ActiveWorkbook.Worksheets
        lrow = Cells(Rows.Count, 1).End(xlUp).Row
        Set rngMerge = Current.Range("A2:B" & lrow)

MergeAgain:
        For Each cell In rngMerge
            If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
                Range(cell, cell.Offset(1, 0)).Merge
                GoTo MergeAgain
            End If
        Next

    Next Current

    ' Turn screen updating back on
    Application.Calculation = xlCalculationAutomatic

End Sub

任何有关完成此操作的指导将不胜感激！

Answer 1

这很难解决。合并 A 列后，在合并 B 列中顺序匹配的单元格时，我可以检查 A 列中的相邻单元格是否合并 cell.Offset(0, -1).MergeCell.我还可以获得第一个合并行 j = cell.Offset(0, -1).MergeArea.Row 并通过计算合并行的计数来计算最后一个合并行k = cell.Offset(0, -1).MergeArea.Count 并设置 lastmergerow = j + k -1（减去1 获取 MergeArea 的结尾）。

然而，关键是在遍历范围时设置和更新变量。在下面的代码中，我更新了范围的开始行和结束行，以防止从 A 列合并到 MergeArea。这使我能够合并 B 列中顺序匹配的值，同时保持在 A 列的 MergeArea 中。

尽可能避免使用合并的单元格！！！但是，在很少有人需要这样做的情况下，我希望以下代码能有所帮助。

我的最终代码：

    Sub MergeB()
    ' Merge Category (Column B) where sequentially matching rows exist while staying within the range of merged cells in Administration (Column A)
    ' Turn off screen updating
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    On Error Resume Next
    Dim Current As Worksheet
    Dim lrow As Long
    Dim k As Long
    Dim j As Long
    Dim bRow As Long
    Dim endRow As Long
        For Each Current In ActiveWorkbook.Worksheets
        bRow = 2
        lrow = Cells(Rows.Count, 2).End(xlUp).Row
        endRow = Cells(Rows.Count, 2).End(xlUp).Row
    MergeAgain:
        Set rngMerge = Current.Range("B" & bRow & ":B" & lrow)
                    For Each cell In rngMerge
                    If cell.Offset(0, -1).MergeCells Then
                        k = cell.Offset(0, -1).MergeArea.Count
                        j = cell.Offset(0, -1).MergeArea.Row
                        lastmergerow = j + k - 1
                        m = k - 1
                    End If
                    Dim i As Integer
                        For i = 1 To m
                            If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False And bRow < lastmergerow Then
                                Range(cell, cell.Offset(1, 0)).Merge
                                bRow = bRow + 1
                            Else
                                bRow = bRow + 1
                                lrow = lastmergerow
                                If bRow > endRow Then
                                    GoTo NextSheet
                                End If
                                If bRow > lrow Then
                                    lrow = endRow
                                End If
                                GoTo MergeAgain
                            End If
                        Next i
                                bRow = lastmergerow + 1
                                lrow = endRow
                                GoTo MergeAgain
                    Next
    NextSheet:
                Next Current
    ' Turn screen updating back on
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Call AutoFit
    End Sub

VBA Excel - 根据A列合并合并B列中的单元格

VBA Excel - Merge cells in column B based on column A merge

excel

mergesort

vba