如何检查列中是否有重复值，然后合并发现的相邻列？

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。请注意，未合并（重复）的公式可能是意外的。