如果值相等，则合并一个特定列的单元格

Posted 2023-02-23

【中文标题】如果值相等，则合并一个特定列的单元格

【英文标题】：Merge Cells of one specific column if equal value

【发布时间】：2015-07-20 23:37:26

【问题描述】：

我需要遍历所有行（除了我的标题行）并合并同一列中具有相同值的所有单元格。在我这样做之前，我已经确定该列已排序。 所以我有一些这样的设置。

a b c d e
1 x x x x 
2 x x x x
2 x x x x
2 x x x x
3 x x x x
3 x x x x

需要这个

a b c d e
1 x x x x 
2 x x x x
  x x x x
  x x x x
3 x x x x
  x x x x

通过我的代码，我实现了合并两个相等的单元格。相反，我需要合并所有相等的单元格。

Dim i As Long
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
    If Cells(i, 1) <> "" Then
        If Cells(i, 1) = Cells(i - 1, 1) Then
            Range(Cells(i, 1), Cells(i - 1, 1)).Merge
        End If
    End If
Next i

【问题讨论】：

重要的是，代码只合并特定列的单元格，而不是工作表的所有列。

这应该可以解决问题...Sub MergeColumnA() Dim i As Long Dim myLastRow As Long Application.DisplayAlerts = False myLastRow = Cells(Rows.Count, "A").End(xlUp).Row For i = myLastRow - 1 To 6 Step -1 If Cells(i + 1, 1) <> "" Then If Cells(i, 1) = Cells(i + 1, 1) Then Range(Cells(i, 1), Cells(i + 1, 1)).Merge End If Next i Application.DisplayAlerts = True End Sub

【参考方案1】：

此方法不使用合并单元格，但达到相同的视觉效果：

假设我们从：

运行这个宏：

Sub HideDups()
    Dim N As Long, i As Long
    N = Cells(Rows.Count, "A").End(xlUp).Row
    For i = N To 3 Step -1
        With Cells(i, 1)
            If .Value = Cells(i - 1, 1).Value Then
                .Font.ColorIndex = 2
            End If
        End With
    Next i
End Sub

会产生这个结果：

注意：

没有合并单元格。这种视觉效果是相同的，因为通过使字体颜色与单元格背景颜色相同来“隐藏”同一列中的连续重复项。

【讨论】：

不错的方法。我很感激。有道理，因为合并后的单元格会丢失某种信息并给格式化带来很多麻烦。

@gco 当我必须制作“看起来像”数据透视表的报表时，我会使用此方法。

太棒了，我将来一定会使用它。无论如何，我的同事需要合并单元格（有关解决方案，请参阅我在问题中的评论）。

@gco 我至少会和你的同事讨论替代方案。

【参考方案2】：

我知道这是一个旧线程，但我需要类似的东西。这就是我想出的。

Sub MergeLikeCells()

    Dim varTestVal As Variant
    Dim intRowCount As Integer
    Dim intAdjustment As Integer

    ActiveSheet.Range("A1").Select
    'Find like values in column A - Merge and Center Cells
    While Selection.Offset(1, 0).Value <> ""
     'If instead you have blanks in the column, change the prev statement to While Selection.Offset(1, 0).Value <> "." and add "." to the last 2 rows of the data
        intRowCount = 1
        varTestVal = Selection.Value
        While Selection.Offset(1, 0).Value = varTestVal
            intRowCount = intRowCount + 1
            Selection.Offset(1, 0).Select
            Selection.ClearContents
        Wend
        intAdjustment = (intRowCount * -1) + 1
        Selection.Offset(intAdjustment, 0).Select
        Selection.Resize(intRowCount, 1).Select
        With Selection
            .Merge
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
        Selection.Offset(1, 0).Resize(1, 1).Select
    Wend

End Sub

【参考方案3】：

我的解决方案如下，祝你有美好的一天！

Sub MergeSameValue()
    Application.DisplayAlerts = False
    Dim LastRow As Integer
    Dim StartRow As Integer
    StartRow = 2
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    
    Dim StartMerge As Integer
    StartMerge = StartRow
    
    For i = StartRow + 1 To LastRow
        If Cells(i, 1) <> "" Then
            If Cells(i, 1) <> Cells(i - 1, 1) Then
                Range(Cells(i - 1, 1), Cells(StartMerge, 1)).Merge
                StartMerge = i
            End If
        End If
    Next i
End Sub