How to combine or merge cells with the same values vertically and horizontally , Excel VBA?

Question

I have sheet with same data in adjacent cells,I could to merge same cells on column A. now I need to merge or combine adjacent same cells beside merged cells on column A , meaning if A2:A3 is same that will be merged and subsequently merge B2:B3 ,C2:C3, D2:D3 until column L.

Update: any method other than Merge will be good also

Sub Merge_Similar_Cells()

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
     
    Dim LastRow As Long
    Dim ws As Worksheet
    Dim WorkRng As Range
    
    Set ws = ActiveSheet
    
    ws.AutoFilter.ShowAllData
    ws.AutoFilter.Sort.SortFields.Clear
    
    LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
     
    ws.AutoFilter.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ws.AutoFilter.Sort.Apply
                                                                                     
    Set WorkRng = ws.Range("A2:A" & LastRow)

CheckAgain:
    For Each cell In WorkRng
        If cell.Value = cell.Offset(1, 0).Value And Not IsEmpty(cell) Then
            Range(cell, cell.Offset(1, 0)).Merge
            cell.VerticalAlignment = xlCenter
            GoTo CheckAgain
        End If
    Next

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub

In your "before" image, rows 2 and 3 are identical. If that's true, then why merge the cells? Why not delete row 3? — PeterT, Sep 08 '21 at 15:46
First, [do](https://edu.gcfglobal.org/en/excel-tips/why-you-should-avoid-merging-cells/1/) [not](https://itstraining.wichita.edu/excel-dont-merge-those-cells-here-is-an-alternative/) [merge cells](https://theexcelclub.com/stop-do-not-merge-cells-in-excel-heres-why-with-fixes/). Instead, copy the data from the lower cells and append it to the end of the upper cell. Then you can delete row 3 (in your example) and retain all the data. — PeterT, Sep 08 '21 at 15:52
Merging cells is a very bad idea especially if you are using filters (as I can see in your sceenshots you are using filters). Filters will break as soon as you have merged cells. Do not merge cells (unless this is the last thing you do before exporting as PDF or printing). Merging cells causes a lot of issues. — Pᴇʜ, Sep 08 '21 at 16:14
Are you sure that you want merging the cells, as your question stated? The @PeterT's idea looks the most convenient for me. Visually you obtain a similar efect and the filtering should not be affected... — FaneDuru, Sep 08 '21 at 16:59
Are there more than two similar consecutive rows to be merged? I can see three such rows for Work Order '10335374'. Is it possible to be more than 3 such identic rows? — FaneDuru, Sep 08 '21 at 17:26
@FaneDuru yes, there are more than two similar consecutive rows to be merged. kindly see hyperlink for the sheet itself uploaded. — Leedo, Sep 08 '21 at 17:29
OK. I will prepare an answer to your question, as it states. I am busy not, but if I will find some time, I will also try the variant I suggested like looking more convenient... — FaneDuru, Sep 08 '21 at 17:50

FaneDuru · Accepted Answer · 2021-09-10T07:19:40.547

Please, test the next code:

Sub Merge_Similar_Cells()
    Dim LastRow As Long, ws As Worksheet, arrWork, i As Long, j As Long, k As Long
    
    Set ws = ActiveSheet
    
    If ws.AutoFilterMode Then 'for the case when the sheet range is not filtered
        ws.AutoFilter.ShowAllData
        ws.AutoFilter.Sort.SortFields.Clear
    End If
    LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
     
    ws.AutoFilter.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ws.AutoFilter.Sort.Apply
                                                                                     
    arrWork = ws.Range("A1:A" & LastRow).Value2 'place the range in an array to make iteration faster
    
    Application.DisplayAlerts = False: Application.ScreenUpdating = False
    For i = 2 To UBound(arrWork) - 1            'iterate between the array elements:
        If arrWork(i, 1) = arrWork(i + 1, 1) Then
            'determine how many consecutive similar rows exist:_________
            For k = 1 To LastRow
                If i + k + 1 >= UBound(arrWork) Then Exit For
                If arrWork(i, 1) <> arrWork(i + k + 1, 1) Then Exit For
            Next k '____________________________________________________
            For j = 1 To 12
                ws.Range(ws.Cells(i, j), ws.Cells(i + k, j)).Merge 'merge all the necessary cells based on previously determined k
           Next j
           ws.Range(ws.Cells(i, 1), ws.Cells(i + k, 12)).VerticalAlignment = xlCenter 'apply vertical alignment for all obtained merged row
         i = i + k: If i >= UBound(arrWork) - 1 Then Exit For 'increment the i variable and exiting if the resulted value exits the array size
       End If
    Next i
    Application.DisplayAlerts = True: Application.ScreenUpdating = True
    MsgBox "Ready..."
End Sub

Edited:

Please, try the next code, which does not merge similar rows on identic column. It delete the similar rows, keeping only one and append the cells values in the range "M:P", separated by vbLf (placing on a separate row in the same cell):

Sub DeleteSimilarRows_AppendLastColuns()
    Dim LastRow As Long, ws As Worksheet, arrWork, rngDel As Range, i As Long, j As Long, k As Long
    Dim strVal As String, m As Long, boolNoFilter As Boolean
    
    Set ws = ActiveSheet
    
    If ws.AutoFilterMode Then             'for the case when the sheet range is not filtered
        ws.AutoFilter.ShowAllData
        ws.AutoFilter.Sort.SortFields.Clear
        
        LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row: boolNoFilter = True
        
        ws.AutoFilter.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        ws.AutoFilter.Sort.Apply
    End If
    
     If Not boolNoFilter Then LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    arrWork = ws.Range("A1:A" & LastRow).Value2 'place the range in an array to make iteration faster
    
    Application.DisplayAlerts = False: Application.ScreenUpdating = False
    For i = 2 To UBound(arrWork) - 1                  'iterate between the array elements:
        If arrWork(i, 1) = arrWork(i + 1, 1) Then
            'determine how many consecutive similar rows exist:______
            For k = 1 To LastRow
                If i + k + 1 >= UBound(arrWork) Then Exit For
                If arrWork(i, 1) <> arrWork(i + k + 1, 1) Then Exit For
            Next k '_________________________________________
            For j = 13 To 16                  'build the concatenated string of cells in range "M:P":
                strVal = ws.Cells(i, j).Value
                For m = 1 To k
                    strVal = strVal & vbLf & ws.Cells(i + m, j).Value
                Next m
                ws.Cells(i, j).Value = strVal: strVal = ""
           Next j
           For m = 1 To k                    'place the cells for rows to be deleted in a Union range, to delete at the end, at once
                If rngDel Is Nothing Then
                     Set rngDel = ws.Range("A" & i + m)
                Else
                    Set rngDel = Union(rngDel, ws.Range("A" & i + m))
                End If
         Next m
         i = i + k: If i >= UBound(arrWork) - 1 Then Exit For 'increment the i variable and exiting if the resulted value exits the array size
       End If
    Next i
    If Not rngDel Is Nothing Then rngDel.EntireRow.Delete    'delete the not necessary rows
    ws.UsedRange.EntireRow.AutoFit: ws.UsedRange.EntireColumn.AutoFit
    Application.DisplayAlerts = True: Application.ScreenUpdating = True
    MsgBox "Ready..."
End Sub

@Waleed_wwm I will post the second variant in some minutes. I am working it now... — FaneDuru, Sep 08 '21 at 18:21
@FaneDure. Just note, although your first code take care if filter is not applied , but I tested without filter and it gives error on line ws.AutoFilter.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal — Leedo, Sep 08 '21 at 18:24
@Waleed_wwm I didn't care too much about the filtering. I must confess I only focused on the part doing the merging and the same in the new code I've just posted. For the case of no filter, the part raising the error should also be introduced between `If ws.AutoFilterMode Then` and `End If`. Please, test the second code and send some feedback. In fact, I will make now the above mentioned modification, in this last version... Updated as I said. — FaneDuru, Sep 08 '21 at 18:29
@FaneDure. second code works perfectly also. Many thanks FaneDure for all your Support. — Leedo, Sep 08 '21 at 18:57
@Waleed_wwm Please, explain what problems appear. This should appear only in case of inconsistencies in the processed data. I would like to know **what to be checked**. Something like "On the row xx it should be "qqqqq" instead of "wwww', because ..... — FaneDuru, Sep 10 '21 at 06:40
@Waleed_wwm Please, test the updated (second) code. It was not a matter of inconsistency, like I initially suspected. I used `k` instead of `m` and it used to work only for the cases of 1 and 2 similar Work Orders... — FaneDuru, Sep 10 '21 at 07:22
@Waleed_wwm I also checked the first code and it does not have such a problem... The problem was connected only with the way of concatenation the existing records (M:P). Please, download the processed workbook from [here](https://easyupload.io/ok2t6y) and send some feedback. — FaneDuru, Sep 10 '21 at 07:30
@FaneDure the update second code (stack overflow) works like a charm , yes first code does not has a problem. about second code on (download the processed workbook), it stop on this line "If i = 47 Then Stop" without any error { no problem with me as there one works }. Please accept my apology because I initially marked this question as answered before I thoroughly check all sheet — Leedo, Sep 10 '21 at 11:51
Please, delete that line. I used it only to stop code and see what,s happening on that line... — FaneDuru, Sep 10 '21 at 11:59
`Set rngDel = Union(rngDel, ws.Range("A" & i + m))` this line that macro takes long time to finish — Leedo, May 06 '22 at 11:42
@Leedo How do you know that the line you show "takes long time to finish"? I the range to be deleted is huge, all process may take some time, but about 100 times less than deleting the rows one by one... — FaneDuru, May 06 '22 at 18:34
I know by commenting the `union line` (then the macro took 0.2 seconds) , and I had to post another additional question to fix this issue https://stackoverflow.com/questions/72141217/faster-method-to-delete-a-range-of-rows-other-that-using-union — Leedo, May 06 '22 at 18:38
@Leedo If the range is huge, you can try iterating backwards and use some slices of `Union` ranges and delete them. I mean, for huge ranges to be processed (with also huge `Union` range), the code speed decreases considerable, so, if this is your case, you need to delete the `Union` range, let us say at 300 - 500 (it depends on occurrences frequency) iterations, and set the range `= Nothing`. For huge ranges, what you gain by making the `Union` range, is shows down when the range becomes huge. I am not near to my computer to show you what I mean, but it should not be so complicated, I think... — FaneDuru, May 06 '22 at 20:28

How to combine or merge cells with the same values vertically and horizontally , Excel VBA?

1 Answers1

Linked