How to check column for duplicate values, then merge adjacent columns if found?

Question

I am trying to create a macro that checks for duplicate values in a column, then merges those rows if found.

I have tried using a loop to check each cell and cell.Offset(1,0) and if they are equal, merge them. Then copy the formatting from that column to an adjacent column.

This image shows what I am trying to accomplish.

I am only trying to merge one column (E) but the issue is it only checks two cells at a time, so it doesnt merge 5 of the same values. It also messes up if the last row is merged. Once the checked column is merged I am just going to copy formatting to the adjacent appropriate columns.

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

This question has been asked here before by many others. Have you tried taking a look? — urdearboy
Any code you tried so far? When do you consider rows as to be merged? Only if the Project ID and Acct is equal? If yes what about differences in the remaining columns? What should happen with them when you merge the rows? — Storax
@Storax I just added the code that I tried making. I am only trying to merge one column (E) but the issue is it only checks two cells at a time, so it doesnt merge 5 of the same values. It also messes up if the last row is merged. — Dave
@urdearboy Yes I have looked at many pages of similar questions to no avail. — Dave

Asger Asger · Accepted Answer · 2019-02-02T11:57:24

merge cells vertically

This code checks the cells of each row and merges cells vertically, if they have the same value (also formulas whith same resulting value!):

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

As your example shows a non-uniform structure, this may be a good solution. If you just want to decide by one row, which neighbor-cells to merge, keep in mind, that only the content of the upper left cell of a merged area "survives".

If you want to address the content of a merged area, then currentRng.MergeArea.Cells(1) will always represent the first cell of the merged area, where the content is.

unmerge

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

As the Find function is bad in finding the last used column or row in merged cells, I use the standard UsedRange instead. Be aware, that unmerged (duplicated) formulas may be unexpected.

How to check column for duplicate values, then merge adjacent columns if found?

1 Answers

merge cells vertically

unmerge