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

Question

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

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

Answer 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

会产生这样的结果：

注意：

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

Answer 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

Answer 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