Need VBA code to merge rows of same entry within a column

[Akash Yadav]

I need to merge rows with similar entries within a column. One important thing to notice is that I do not want to merge 2 row cells if their row cell to their left are different. For example in this example : There is a break in merging of As when entries on their left are different i.e B and C. Thanks in advance.

 

[Ezguy4u]

Akash let's get the ball rolling. Now the solution is only as good as the information we get. At least this will start the conversation. This might generate more questions then answers. But we have to start some place.

Sub Move1()

Dim CellCnt As Long
Dim row1 As Long
Dim row2 As Long

row2 = 1

CellCnt = Cells(Rows.Count, 1).End(xlUp).Row

For row1 = 1 To CellCnt
If Cells(row1, 2) <> Cells(row1 + 1, 2) Then

Cells(row2, 4) = Cells(row1, 1)
Cells(row2, 5) = Cells(row1, 2)
Cells(row2, 6) = Cells(row1, 3)
row2 = row2 + 1

End If

Next row1

End Sub

Book1
	A	B	C	D	E	F
1	1	B	A	1	B	A
2	1	B	A	1	C	A
3	1	B	A	2	D	A
4	1	C	A
5	1	C	A
6	1	C	A
7	2	D	A
8	2	D	A
9	2	D	A
10	2	D	A
Sheet1 (5)

 

[VBasic2008]

Merge Equal Cells in Column Range

Option Explicit

Sub mergeEqualCells()
    
    ' Define constants.
    Const wsName As String = "Sheet1"
    Const FirstCell As String = "A1"
    Const Offs As Long = 2
    ' Define workbook.
    Dim wb As Workbook
    Set wb = ThisWorkbook
    
    ' Define Source Column Range.
       
    ' Define worksheet
    Dim ws As Worksheet
    Set ws = wb.Worksheets(wsName)
    ' Define Source Column Range.
    Dim rng As Range
    Set rng = ws.Range(FirstCell)
    Dim Col As Long
    Col = rng.Column
    Dim FirstRow As Long
    FirstRow = rng.Row
    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
    If LastRow < FirstRow Then
        GoTo ProcExit
    End If
    Set rng = ws.Columns(rng.Column).Resize(LastRow)
    
    ' Write values from Source Column Range to Data Array.
    
    Dim Data As Variant
    If rng.Cells.Count > 1 Then
        Data = rng.Value
    Else
        ReDim Data(1 To 1, 1 To 1)
        Data(1, 1) = rng.Value
    End If
    
    ' Prepare to write from Data Array to Target Column Range.
    
    Dim First As Long
    First = FirstRow
    Dim CurVal As Variant
    CurVal = ws.Cells(First, Col).Value
    Dim CurSize As Long
    CurSize = 1
    Dim i As Long
    
    Application.ScreenUpdating = False
    
    With rng.Offset(, Offs)
        .Clear
        ' Or something like the following combination.
        '.UnMerge
        '.ClearContents
    End With
    
    ' Write from Data Array to Target Column Range.
    
    For i = FirstRow + 1 To LastRow
        If Data(i, 1) <> Data(i - 1, 1) Then
            With ws.Cells(First, Col + Offs)
                .Value = CurVal
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                If CurSize > 1 Then
                    With .Resize(CurSize)
                        .Merge
                    End With
                End If
            End With
            First = i
            CurVal = ws.Cells(First, Col).Value
            CurSize = 1
        Else
            CurSize = CurSize + 1
        End If
    Next i
    With ws.Cells(First, Col + Offs)
        .Value = CurVal
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        If CurSize > 1 Then
            With .Resize(CurSize)
                .Merge
            End With
        End If
    End With
    
    Application.ScreenUpdating = True
    
    ' Inform user.
    
    MsgBox "Cells merged.", vbInformation, "Success"
    
ProcExit:
End Sub

 

[Peter_SSs]

Welcome to the MrExcel board!

Is this what you mean? Test with a copy of your data.

Sub Merge_Cells()
  Dim r As Long, rws As Long
  
  Application.DisplayAlerts = False
  r = 1
  Do Until r > Range("B" & Rows.Count).End(xlUp).Row
    r = r + 1
    If Cells(r, 2).Value = Cells(r - 1, 2).Value And Cells(r, 1).Value = Cells(r - 1, 1).Value Then
      rws = rws + 1
    Else
      If rws > 1 Then
        With Cells(r - rws, 2).Resize(rws)
          .Merge
          .VerticalAlignment = xlCenter
          .HorizontalAlignment = xlCenter
        End With
      End If
      rws = 1
    End If
  Loop
  Application.DisplayAlerts = True
End Sub

Before:

Akash Yadav.xlsm
	A	B	C
1
2	1	B	A
3	1	B	A
4	1	B	A
5	1	C	A
6	1	C	A
7	2	D	A
8	2	D	A
Sheet1

After:

Akash Yadav.xlsm
	A	B	C
1
2	1	B	A
3	1		A
4	1		A
5	1	C	A
6	1		A
7	2	D	A
8	2		A
Sheet1