如果值相等，則合並一特定列的單元格

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

會產生這樣的結果：

筆記：

沒有單元格被合並。 這種視覺效果是相同的，因為通過使字體的顏色與單元格背景的顏色相同，同一列中的連續重復項被“隱藏”。

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