Merging Cells

Ark68

Well-known Member
Joined
Mar 23, 2004
Messages
3,812
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
What would be the best approach in VBA, to assess a column of cells in which there are contingent cells of different sizes having the same value, and merge them.

Example:
<b>Excel 2010</b><table cellpadding="2.5px" rules="all" style=";background-color: #FFFFFF;border: 1px solid;border-collapse: collapse; border-color: #BBB"><colgroup><col width="25px" style="background-color: #DAE7F5" /><col /></colgroup><thead><tr style=" background-color: #DAE7F5;text-align: center;color: #161120"><th></th><th>V</th></tr></thead><tbody><tr ><td style="color: #161120;text-align: center;">24</td><td style=";">ORIGINAL</td></tr><tr ><td style="color: #161120;text-align: center;">25</td><td style=";">Dog</td></tr><tr ><td style="color: #161120;text-align: center;">26</td><td style=";">Dog</td></tr><tr ><td style="color: #161120;text-align: center;">27</td><td style=";">Dog</td></tr><tr ><td style="color: #161120;text-align: center;">28</td><td style=";">Dog</td></tr><tr ><td style="color: #161120;text-align: center;">29</td><td style=";">Hamster</td></tr><tr ><td style="color: #161120;text-align: center;">30</td><td style=";">Cat</td></tr><tr ><td style="color: #161120;text-align: center;">31</td><td style=";">Cat</td></tr><tr ><td style="color: #161120;text-align: center;">32</td><td style=";">Bird </td></tr><tr ><td style="color: #161120;text-align: center;">33</td><td style=";">Bird </td></tr><tr ><td style="color: #161120;text-align: center;">34</td><td style=";">Bird </td></tr></tbody></table><p style="width:1.8em;font-weight:bold;margin:0;padding:0.2em 0.6em 0.2em 0.5em;border: 1px solid #BBB;border-top:none;text-align: center;background-color: #DAE7F5;color: #161120">RPL</p><br /><br />

<b>Excel 2010</b><table cellpadding="2.5px" rules="all" style=";background-color: #FFFFFF;border: 1px solid;border-collapse: collapse; border-color: #BBB"><colgroup><col width="25px" style="background-color: #DAE7F5" /><col /></colgroup><thead><tr style=" background-color: #DAE7F5;text-align: center;color: #161120"><th></th><th>V</th></tr></thead><tbody><tr ><td style="color: #161120;text-align: center;">24</td><td style=";">ALTERED</td></tr><tr ><td style="color: #161120;text-align: center;">25</td><td style=";">Dog</td></tr><tr ><td style="color: #161120;text-align: center;">26</td><td style=";"></td></tr><tr ><td style="color: #161120;text-align: center;">27</td><td style=";"></td></tr><tr ><td style="color: #161120;text-align: center;">28</td><td style=";"></td></tr><tr ><td style="color: #161120;text-align: center;">29</td><td style=";">Hamster</td></tr><tr ><td style="color: #161120;text-align: center;">30</td><td style=";">Cat</td></tr><tr ><td style="color: #161120;text-align: center;">31</td><td style=";"></td></tr><tr ><td style="color: #161120;text-align: center;">32</td><td style=";">Bird </td></tr><tr ><td style="color: #161120;text-align: center;">33</td><td style=";"></td></tr><tr ><td style="color: #161120;text-align: center;">34</td><td style=";"></td></tr></tbody></table><p style="width:1.8em;font-weight:bold;margin:0;padding:0.2em 0.6em 0.2em 0.5em;border: 1px solid #BBB;border-top:none;text-align: center;background-color: #DAE7F5;color: #161120">RPL</p><br /><br />

MrExcel HTML i guess does not show merged cells...so imag V25:V28, V30:V31 and V32:V34 merged respectively.
 

Some videos you may like

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.

JoeMo

MrExcel MVP
Joined
May 26, 2009
Messages
17,388
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
One way:
1. Sort the list to ensure that duplicates are contiguous
2. use a for each c in ListRange construct with n = Application.Countif(ListRange,c.value) to determine how many cells to merge.
3. Merge something like:
Code:
    Application.DisplayAlerts = False
    With Range("some part of ListRange")
        .Merge
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
        .WrapText = False
        .MergeCells = True
    End With
 

Ark68

Well-known Member
Joined
Mar 23, 2004
Messages
3,812
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Thanks Joe ... I always appreciate your support. Thank you! I'll give it a try and report back.
 

anvg

Active Member
Joined
Feb 14, 2012
Messages
485
Try it for selection in any column
Code:
Public Sub MergeSelection()
    Dim i As Long, strBefore As String, vBefore As Long
    Dim vCol As Long, vRows As Long
    If TypeOf Selection Is Range Then
        If (Selection.Columns.Count = 1) And (Selection.Rows.Count > 3) Then
            strBefore = "\\\///": vBefore = -1: vCol = Selection.Column
            vRows = Selection.Rows.Count + Selection.Row - 1
            Application.DisplayAlerts = False
            For i = Selection.Row To vRows
                If strBefore <> Cells(i, vCol).Value Then
                    If vBefore > 0 Then
                        If (i - 1 - vBefore) > 0 Then
                            Range(Cells(vBefore, vCol), Cells(i - 1, vCol)).Merge
                        End If
                    End If
                    vBefore = i
                    strBefore = Cells(i, vCol).Value
                End If
            Next i
            If (Cells(vBefore, vCol).Value = Cells(vRows, vCol).Value) And (vBefore < vRows) Then
               Range(Cells(vBefore, vCol), Cells(vRows, vCol)).Merge
            End If
            Application.DisplayAlerts = True
        End If
    End If
End Sub
 

Ark68

Well-known Member
Joined
Mar 23, 2004
Messages
3,812
Office Version
  1. 365
  2. 2016
Platform
  1. Windows

ADVERTISEMENT

Hello folks,

JoeMo was very kind in providing me direction in how to approach my initial request. I've managed to iron out the step 1, but I've had no luck figuring out how to do step 2.

use a for each c in ListRange construct with n = Application.Countif(ListRange,c.value) to determine how many cells to merge.

I don't know much about 'ListRange', and there is a variable, "N", that I'm uncertain where and how to use.

Please refer to the attached workbook to see a sample with before and after merge.

https://docs.google.com/file/d/0B9EE-tbOy4bJZVdPRjliZ2cxUUk/edit?usp=sharing
 

JoeMo

MrExcel MVP
Joined
May 26, 2009
Messages
17,388
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
The "ListRange" was just my way of identifying the range your list is in. If you don't mind the list being sorted to ensure all the like animals are grouped in contiguous cells, see if this does what you want. Assumes your animals are in column A starting in cell A2 - adjust to suit your data.
Code:
Sub MergeLikeCells()
Dim lR As Long, R As Range, n As Long, i As Long
lR = Range("A" & Rows.Count).End(xlUp).Row
Set R = Range("A2", "A" & lR)
R.Sort key1:=[A2], order1:=xlAscending
Application.DisplayAlerts = False
For i = 1 To R.Rows.Count
    If Not R.Cells(i, 1).MergeCells Then
        n = Application.CountIf(R, R.Cells(i, 1).Value)
        If n > 1 Then
            R.Cells(i, 1).Resize(n, 1).Merge
        End If
    End If
Next i
R.VerticalAlignment = xlTop
End Sub
 
Last edited:

Ark68

Well-known Member
Joined
Mar 23, 2004
Messages
3,812
Office Version
  1. 365
  2. 2016
Platform
  1. Windows

ADVERTISEMENT

Hi JoeMo, I'm happy you chose to continue to help me with this. Your efforts are most appreciated.

My data is originally sorted into groups as defined by an array, with each group separated by a black row. Each group is dynamic and holds different numbers of rows.
Within each group, the "animal" cells are sorted into contiguous ranges. I had already done this, so I omitted that portion of your code in my testing.

Here is the code I adapted based on your suggestion:

Rich (BB code):
                Dim y As Range
                Dim n As Long
                
                arr2 = Array("DT", "DR", "DTR", "FR", "FT", "CR", "CT")  ' the different "groups" into which the data rows are placed into. 
                llastrow = .Range("R" & Rows.Count).End(xlUp).Row   ' the number of rows in the database 
                Set rdata = .Range("R13:R" & llastrow)  ' holds values to match the array 
    
                For po = 0 To UBound(arr2)  ' cycle through all groups. 
                    vg = arr2(po)  ' active worksheet (of 8 different worksheets) 
    
                    cntdr = Application.CountIf(rdata, vg)  ' how many instances or 'arr2' exist in the database. 
    
                    If cntdr > 0 Then  ' if no instances of 'arr2' exist, bypass merge. 
            
                        On Error Resume Next
                        lRowst = Application.Match(vg, rdata, 0)  ' get relative row number of 1st instance of 'arr2' 
                        On Error GoTo 0
            
                        lRowst = lRowst + 12  ' actual row number of the start of the 'arr2' group. 
                        lRowed = lRowst + cntdr - 1  ' actual row number of the end of the 'arr2' group. 
                        
                        Set y = .Range("B" & lRowst, "B" & lRowed)  ' Eligible range for merge 
                        Application.DisplayAlerts = False
                        For i = 1 To y.Rows.Count  ' loop for each row in the eligible merge . 
                            If Not y.Cells(i, 1).MergeCells Then
                                n = Application.CountIf(y, y.Cells(i, 1).Value)
                                If n > 1 Then
                                    y.Cells(i, 1).Resize(n, 1).Merge
                                End If
                            End If
                         Next i
                         y.VerticalAlignment = xlTop
                    End If
                
                Next po ' continue to next group. 

In my testing, the first group (arr2 = DT), there are 2 rows (Row 13 and 14). These cells share the same value in B13 andB14, however, they do not merge with this code unfortunately.
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
47,926
Office Version
  1. 365
Platform
  1. Windows
My data is originally sorted into groups as defined by an array, with each group separated by a black row.
I've entered late and may be completely on the wrong track but that blue text makes me think your original data sample was not correct and your data is more like this:

Excel Workbook
V
24
25Dog
26Dog
27Dog
28Dog
29
30Hamster
31
32Cat
33Cat
34
35Bird
36Bird
37Bird
38
Merge Cells



If that happens to be the case, then see if this sort of code is any use.
Test in a copy of your workbook.
Code:
Sub Merge_Cells()
  Dim r As Range
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  For Each r In Range("V25", Range("V" & Rows.Count).End(xlUp)).SpecialCells(xlConstants).Areas
    With r
      If .Rows.Count > 1 Then
        .Merge
        .VerticalAlignment = xlTop
      End If
    End With
  Next r
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub
 

Ark68

Well-known Member
Joined
Mar 23, 2004
Messages
3,812
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Hi Peter ... yes, my error ... one letter black, was indeed supposed to by 'blank', so yor assumption was correct, and as a result, your code does exactly as you had written it to do.

However, I realize now I didn't explain fully.
My data is originally sorted into groups as defined by an array, with each group separated by a black row. Each group is dynamic and holds different numbers of rows.[/code]. So data is grouped by the value in row "R" ... "DT, DR, DTR, ..." as per arr2. Within each group, that group is sorted by "b" to place the cells of column b into a contiguous range within that group.

See this post merge dataset:
Excel Workbook
ABR
1CATDT
2CATDT
3
4BIRDDR
5BIRDDR
6BIRDDR
7BIRDDR
8HAMSTERDR
9
10GIRAFFEDTR
11DOGDTR
12BIRDDTR
13BIRDDTR
14SQUIRRELDTR
15SQUIRRELDTR
16
17FR
18FR
19FR
20FR
21FR
22FR
23FR
24FR
25FR
26FR
27FR
28FR
29FR
30FR
31FR
32
33BIRDCR
34BIRDCR
35BIRDCR
36BIRDCR
WPL


Here is a the data after your merging code vs. the preferred outcome ...

Excel Workbook
ABR
1Peter's Code results . . .
2
3CATDT
4DT
5
6BIRDDR
7DR
8DR
9DR
10DR
11
12GIRAFFEDTR
13DTR
14DTR
15DTR
16DTR
17DTR
18
19FR
20FR
21FR
22FR
23FR
24FR
25FR
26FR
27FR
28FR
29FR
30FR
31FR
32FR
33FR
34
35BIRDCR
36CR
37CR
38CR
39
40
41Preferred results:
42
43CATDT
44DT
45
46BIRDDR
47DR
48DR
49DR
50HAMSTERDR
51
52GIRAFFEDTR
53DOGDTR
54BIRDDTR
55DTR
56SQUIRRELDTR
57DTR
58
59FR
60FR
61FR
62FR
63FR
64FR
65FR
66FR
67FR
68FR
69FR
70FR
71FR
72FR
73FR
74
75BIRDCR
76CR
77CR
78CR
MrExcel


A tweak I think is needed ...
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
47,926
Office Version
  1. 365
Platform
  1. Windows
OK, now I understand better, I think :)
My previous approach is not suitable for your layout, so try this approach.
Code:
Sub Merge_Cells_v2()
  Dim lr As Long, r As Long
  
  Const mergeCol As String = "B"  '<- columns where cells are to be merged
  Const frData As Long = 1        '<- First row of actual data
  
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  lr = Cells(Rows.Count, mergeCol).End(xlUp).Row
  For r = lr To frData + 1 Step -1
    With Cells(r, mergeCol)
      If .Value = .Offset(-1).Value And .Value <> "" Then
        With .Offset(-1).Resize(2)
          .Merge
          .VerticalAlignment = xlCenter
        End With
      End If
    End With
  Next r
   Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,122,518
Messages
5,596,621
Members
414,082
Latest member
sasmita

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top