CODEWITHSUNDEEP
excelvba
Caprooja
Caprooja

Reputation: 895

Merge duplicate cells?

I have the following input:

Input

and would like the following output:

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?

Upvotes: 1

Views: 5865

Answers (4)

FreeSoftwareServers
FreeSoftwareServers

Reputation: 2791

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

Upvotes: 1

user4039065
user4039065

Reputation:

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

Upvotes: 0

newacc2240
newacc2240

Reputation: 1425

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

Upvotes: 6

Rhys
Rhys

Reputation: 603

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

Upvotes: 2

Related Questions