单元格值匹配时合并单元格（不同的列行值）

Question

我想编写一个 Excel vba 来根据单元格的值和另一列中的引用单元格合并单元格。 就像附图一样。 我有超过 18000 行，有很多变化。 该行内的所有值均按顺序排列。

在此处输入图片说明

这是我基于 VBA 的代码

Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False 
Dim rngMerge As Range, cell As Range
Set rngMerge = Range("B2:C10") 
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
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Answer 1

编辑次要升级以允许扩展合并范围以启用合并更新。

合并具有相等值的垂直相邻单元格。

• 保存在常规模块中。
• 确保常量 ( Const ) 出现在模块中的任何其他代码之前。
• 考虑添加一个保护以确保这只针对工作表运行
  它适用于（请参阅代码后的操作方法）。
• 从Alt - F8宏对话框运行宏。
• 注意像大多数宏一样，这将擦除 Excel 撤消缓冲区。
  它无法通过Ctrl - Z撤消。 （唯一的选择是恢复到上次保存
  或手动编辑为以前的方式。）

复制粘贴

Private Const LastCol = 20
Private Const LastRow = 20

Public Sub Merge_Cells()
    Dim r As Range
    Dim s As Range
    Dim l As Range
    Dim c As Long
    Dim v As Variant
    
    For c = 1 To LastCol
        Set s = Nothing
        Set l = Nothing
        For Each r In Range(Cells(1, c), Cells(LastRow, c))
            v = r.MergeArea(1, 1).Value
            If v = vbNullString Then
                DoMerge s, l
                Set s = Nothing
                Set l = Nothing
            ElseIf s Is Nothing Then
                Set s = r
            ElseIf s.Value <> v Then
                DoMerge s, l
                Set s = r
                Set l = Nothing
            Else
                Set l = r
            End If
        Next r
        DoMerge s, l
    Next c
End Sub

Private Sub DoMerge(ByRef s As Range, ByRef l As Range)
    If s Is Nothing Then Exit Sub
    If l Is Nothing Then Set l = s
    Application.DisplayAlerts = False
    With Range(s, l)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Merge
    End With
    Application.DisplayAlerts = True
End Sub

考虑以编程方式查找最后一列和最后一行。

如果合并应该在第 1 行之后开始：

For Each r In Range(Cells(1, c), Cells(LastRow, c))
                          ^

• 将1更改为正确的行号或替换为添加的const变量。

要保护其他工作表，请使用选项卡名称（建议先重命名选项卡）：

For Each r In Worksheets(TabName).Range(Cells(1, c), Cells(LastRow, c))
              ^^^^^^^^^^^^^^^^^^^^

• 将此编辑与起始行编辑在同一行。
• 并添加Private Const TabName = "The Merge Tabs Name" ' Spaces ok
  到模块的顶部与其他Const (constants) 。
• 或者将名称直接放在代码中： Worksheets("The Merge Tabs Name") 。

Answer 2

将此添加到模块中，选择您的数据范围（不包括标题），运行宏并查看它是否适合您。

Public Sub MergeRange()
    Dim rngData As Range, lngRow As Long, lngCol As Long, strTopCell As String
    Dim strBottomCell As String, strThisValue As String, strNextValue As String
    Dim strThisMergeArea As String, strNextMergeArea As String

    Set rngData = Selection

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    With rngData
        For lngCol = 1 To .Columns.Count
            strTopCell = ""

            For lngRow = 1 To .Rows.Count
                If strTopCell = "" Then strTopCell = .Cells(lngRow, lngCol).Address

                strThisValue = .Cells(lngRow, lngCol)
                strNextValue = .Cells(lngRow + 1, lngCol)

                If lngCol > 1 Then
                    strThisMergeArea = .Cells(lngRow, lngCol - 1).MergeArea.Address
                    strNextMergeArea = .Cells(lngRow + 1, lngCol - 1).MergeArea.Address

                    If strThisMergeArea <> strNextMergeArea Then strNextValue = strThisValue & "."
                End If

                If strNextValue <> strThisValue Or lngRow = .Rows.Count Then
                    strBottomCell = .Cells(lngRow, lngCol).Address

                    With rngData.Worksheet.Range(strTopCell & ":" & strBottomCell)
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                        .MergeCells = True
                    End With

                    strTopCell = .Cells(lngRow + 1, lngCol).Address
                End If
            Next
        Next
    End With

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

对此有一个技巧可以更改，那就是它也将根据前一列进行分组。 您可以在单元格 C19 中看到我正在谈论的内容的示例...

... 已经计算出前一列有一个在该点停止的分组，因此，1 没有通过并分组到下一个批次，它停止并在那里分组。 我希望这是有道理的，我希望它能给你你所需要的。

另一件事，这里的代码将尝试分离您之前合并的所有数据。

Public Sub DeMergeRange()
    Dim rngData As Range, lngRow As Long, lngCol As Long, objCell As Range
    Dim objMergeArea As Range, strMergeRange As String, strFirstCell As String
    Dim strLastCell As String, objDestRange As Range

    Set rngData = Selection

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    With rngData
        For lngCol = 1 To .Columns.Count
            For lngRow = 1 To .Rows.Count
                Set objCell = .Cells(lngRow, lngCol)

                If objCell.Areas(1).MergeArea.Cells.Count > 1 Then
                    strMergeRange = objCell.Areas(1).MergeArea.Address

                    objCell.MergeCells = False

                    strFirstCell = Split(strMergeRange, ":")(0)
                    strLastCell = Split(strMergeRange, ":")(1)

                    Set objDestRange = .Worksheet.Range(.Worksheet.Range(strFirstCell).Offset(1, 0).Address & ":" & strLastCell)

                    .Worksheet.Range(strFirstCell).Copy objDestRange
                End If
            Next
        Next
    End With

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

注意，我的建议是确保在运行任何代码之前将原始源数据保存到另一个工作簿/工作表作为备份。 如果它塞满了您的数据，那么手动撤消将是一种正确的皇家痛苦。