Excel宏合并单元格基于其他合并答案

【问题标题】：Excel Macro Merge Cells Based on Other MergeExcel宏合并单元格基于其他合并
【发布时间】：2018-07-16 14:53:42
【问题描述】：

我需要对超过 7,000 行进行合并和居中。众多列中有 3 列将包含可合并的数据。我无法删除行。我在下面拍了一个小sn-p，希望能证明这一点。

我使用了我发现的这个宏来合并 A 行。效果很好。问题是 B 列和 C 列的合并方式不同。我需要合并基于 A 列的合并方式。 A 列是独一无二的，它从不重复。 B 列和 C 列可能重复，因此合并必须基于 A 列。

用于合并 A 列的代码：

Sub MergeSameCell()
    'Updateby20131127
    Dim Rng As Range, xCell As Range
    Dim xRows As Integer
    xTitleId = "KutoolsforExcel"
    Set WorkRng = Application.Selection
    Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    xRows = WorkRng.Rows.Count
    For Each Rng In WorkRng.Columns
        For i = 1 To xRows - 1
            For j = i + 1 To xRows
                If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
                    Exit For
                End If
            Next
            WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1)).Merge
            i = j - 1
        Next
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

这让我可以合并 A 列（超过 7000 行）中的唯一代码。接下来我需要根据 A 列的合并将其右侧的两列合并。

示例：我需要基于 A 列合并 B 列和 C 列。我无法执行上面列出的为 A 列所做的合并宏，因为 B 列中的“50”跨 A 列合并（01， 02, 03)。相反，无论下一个组的值是什么，我都需要按顺序合并每个组。

我有什么：

我需要什么：

任何帮助将不胜感激！

【问题讨论】：

当您展示您尝试解决特定 您询问的问题的代码时，SO 确实有效.现在，您要求我们为您编写新要求，这超出了 SO 的范围。

标签： vba excel

【解决方案1】：

我确定了答案。我会在这里发布以防其他人遇到此问题。我调整了原始代码并将其保存在宏中。在进行任何排序之前，选择 A 列的所有行，然后按 F5 运行....

Sub MergeSameCell()
'Updateby20131127
Dim Rng As Range, xCell As Range
Dim xRows As Integer
xTitleId = "Multiple Merge & Center"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, 
Type:=8)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
xRows = WorkRng.Rows.Count
For Each Rng In WorkRng.Columns
    For i = 1 To xRows - 1
        For j = i + 1 To xRows
            If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
                Exit For
            ElseIf Rng.Cells(i, 1).Value = "" Then
                Exit For
            End If
        Next
        WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1)).Merge
        WorkRng.Parent.Range(Rng.Cells(i, 2), Rng.Cells(j - 1, 2)).Merge
        WorkRng.Parent.Range(Rng.Cells(i, 3), Rng.Cells(j - 1, 3)).Merge
        i = j - 1
    Next
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

【讨论】：