Merge duplicate cells? - excel

Question

I have the following input:
and would like the following output:
The intended operation is to search column A for duplicate values (column is already sorted). Each duplicate value in A should be merged into 1 cell. Also, merge the same rows in B (take the top value if different, but safe to assume they are the same). Do not touch C.
I'm doing this manually now and it is a huge pain. I am new to VBA but it seems like that would be simple way to speed this up. Any tips?

Answer 1

Sub MergeCells()
'set your data rows here
Dim Rows As Integer: Rows = 20
Dim First As Integer: First = 1
Dim Last As Integer: Last = 0
Dim Rng As Range
Application.DisplayAlerts = False
With ActiveSheet
For i = 1 To Rows + 1
If .Range("A" & i).Value <> .Range("A" & First).Value Then
If i - 1 > First Then
Last = i - 1
Set Rng = .Range("A" & First, "A" & Last)
Rng.MergeCells = True
Set Rng = .Range("B" & First, "B" & Last)
Rng.MergeCells = True
End If
First = i
Last = 0
End If
Next i
End With
Application.DisplayAlerts = True
End Sub

Answer 2

I've done this a few times...
Public Sub MergeDuplicates()
'disable alerts to avoid clicking OK every time it merges
Application.DisplayAlerts = False
'define the range
Dim r As Range
Set r = Sheets("Sheet1").Range("A1:B4")
'need a row counter
Dim i As Long
i = 1
'variables to store the value in A in a row and its upstairs neighbor
Dim this_A As String
Dim last_A As String
'step through the rows of the range
For Each rw In r.Rows
If i > 1 Then 'only compare if this is not the first row - nothing to look backwards at!
'get the values of A for this row and the one before
this_A = rw.Cells(1, 1).Value
last_A = rw.Cells(1, 1).Offset(-1, 0).Value
'compare this A to the one above; if they are the same, merge the cells in both columns
If this_A = last_A Then
'merge the cells in column A
Sheets("Sheet1").Range(r.Cells(i - 1, 1), r.Cells(i, 1)).Merge
'merge the cells in column B
Sheets("Sheet1").Range(r.Cells(i - 1, 2), r.Cells(i, 2)).Merge
End If
End If
i = i + 1 'increment the counter
Next rw
'enable alerts
Application.DisplayAlerts = True
End Sub

Answer 3

Try this, easily adaptible as the range can be modified without changing anything else.
Sub MergeRng
Dim Rng As Range, xCell As Range, WorkRng As Range
Dim xRows As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set WorkRng = Activeworkbook.ActiveSheet.Range("A1:B4")
xRows = WorkRng.Rows.Count
For Each Rng In WorkRng.Columns
For i = 1 To xRows - 1
For j = i + 1 To xRows
If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
Exit For
End If
Next
With WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1))
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
i = j - 1
Next
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Source:
https://www.extendoffice.com/documents/excel/1138-excel-merge-same-value.html

Answer 4

You have indicated that column A was sorted; it seems to me that both column A and column B should be sorted with column A as the primary key and column B as the secondary key.
Option Explicit
Sub wqwerq()
Dim i As Long, d As Long
Application.DisplayAlerts = False
With Worksheets("sheet3")
With .Cells(1, "A").CurrentRegion
.Cells.Sort Key1:=.Columns(1), Order1:=xlAscending, _
Key2:=.Columns(2), Order2:=xlDescending, _
Orientation:=xlTopToBottom, Header:=xlNo
For i = .Rows.Count To 1 Step -1
If Not .Cells(i, "B").MergeCells Then
d = Application.CountIfs(.Columns(1), .Cells(i, "A"), .Columns(2), .Cells(i, "B"))
If CBool(d - 1) Then
With .Cells(i, "B")
.Resize(d, 1).Offset(1 - d, 0).Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End If
End If
If i = Application.Match(.Cells(i, "A"), .Columns(1), 0) Then
d = Application.CountIfs(.Columns(1), .Cells(i, "A"))
If CBool(d - 1) Then
With .Cells(i, "A")
.Resize(d, 1).Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End If
End If
Next i
End With
End With
Application.DisplayAlerts = True
End Sub