如何检查列是否有重复值，如果找到则合并相邻列？

Question

我正在尝试创建一个宏来检查列中的重复值，然后在找到时合并这些行。

我尝试使用循环检查每个单元格和cell.Offset(1,0)，如果它们相等，则合并它们。然后将格式从该列复制到相邻列。

这张图片显示了我想要完成的事情。

我只是想合并一列 (E)，但问题是它一次只检查两个单元格，所以它不会合并 5 个相同的值。如果最后一行被合并，它也会搞砸。合并选中的列后，我只需将格式复制到相邻的相应列。

Sub Merge()

Dim lastRow As Long
lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

Application.DisplayAlerts = False

    For Each cell In Range("E1:E" & lastRow)
        If cell.Offset(1, 0).Value = cell.Value Then
           Range(cell, cell.Offset(1, 0)).Merge
        End If
    Next cell
End Sub

Answer 1

垂直合并单元格

此代码检查每行的单元格并垂直合并单元格，如果它们具有相同的值（还有具有相同结果值的公式！）：

Sub MergeCellsVertically()
    Dim ws As Worksheet
    Dim currentRng As Range
    Dim usedRows As Long, usedColumns As Long
    Dim currentRow As Long, currentColumn As Long
    
    Set ws = ActiveSheet
    usedRows = ws.Cells.Find(What:="*", After:=ws.Cells(1), LookIn:=xlFormulas, _
        SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    usedColumns = ws.Cells.Find(What:="*", After:=ws.Cells(1), LookIn:=xlFormulas, _
        SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    
    Application.DisplayAlerts = False
    For currentColumn = 1 To usedColumns
        For currentRow = usedRows To 2 Step -1
            Set currentRng = ws.Cells(currentRow, currentColumn)
            If currentRng.Value <> "" Then
                If currentRng.Value = currentRng.Offset(-1, 0).Value Then
                    currentRng.Offset(-1, 0).Resize(2, 1).Merge
                End If
            End If
        Next currentRow
    Next currentColumn
    Application.DisplayAlerts = True
    
    Set currentRng = Nothing
    Set ws = Nothing
End Sub

由于您的示例显示了不统一的结构，这可能是一个很好的解决方案。如果您只想通过一行来决定要合并哪些相邻单元格，请记住，只有合并区域左上角单元格的内容才能“存活”。

如果要处理合并区域的内容，则currentRng.MergeArea.Cells(1) 将始终表示合并区域的第一个单元格，即内容所在的位置。

取消合并

Sub UnmergeCells()
    Dim ws As Worksheet
    Dim usedRows As Long, usedColumns As Long
    Dim currentRng As Range, tempRng As Range
    Dim currentRow As Long, currentColumn As Long
    
    Set ws = ActiveSheet
    usedRows = ws.UsedRange.Cells(1).Row + ws.UsedRange.Rows.Count - 1
    usedColumns = ws.UsedRange.Cells(1).Column + ws.UsedRange.Columns.Count - 1
    
    For currentRow = 1 To usedRows
        For currentColumn = 1 To usedColumns
            Set currentRng = ws.Cells(currentRow, currentColumn)
            If currentRng.MergeCells Then
               Set tempRng = currentRng.MergeArea
               currentRng.MergeArea.UnMerge
               currentRng.Copy tempRng
            End If
        Next currentColumn
    Next currentRow
    
    Set tempRng = Nothing
    Set currentRng = Nothing
    Set ws = Nothing
End Sub

由于Find 函数无法在合并单元格中查找最后使用的列或行，因此我改用标准的UsedRange。请注意，未合并（重复）的公式可能是意外的。