Merging Cells

[Ark68]

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:

Excel 2010
	V
24	ORIGINAL
25	Dog
26	Dog
27	Dog
28	Dog
29	Hamster
30	Cat
31	Cat
32	Bird
33	Bird
34	Bird
RPL

Excel 2010
	V
24	ALTERED
25	Dog
26
27
28
29	Hamster
30	Cat
31
32	Bird
33
34
RPL

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

 

[JoeMo]

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:

    Application.DisplayAlerts = False
    With Range("some part of ListRange")
        .Merge
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
        .WrapText = False
        .MergeCells = True
    End With

 

[Ark68]

Thanks Joe ... I always appreciate your support. Thank you! I'll give it a try and report back.

 

[anvg]

Try it for selection in any column

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]

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]

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.

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

 

[Ark68]

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:

                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]

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
25	Dog
26	Dog
27	Dog
28	Dog
29
30	Hamster
31
32	Cat
33	Cat
34
35	Bird
36	Bird
37	Bird
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.

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]

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
	A	B	R
1		CAT	DT
2		CAT	DT
3
4		BIRD	DR
5		BIRD	DR
6		BIRD	DR
7		BIRD	DR
8		HAMSTER	DR
9
10		GIRAFFE	DTR
11		DOG	DTR
12		BIRD	DTR
13		BIRD	DTR
14		SQUIRREL	DTR
15		SQUIRREL	DTR
16
17			FR
18			FR
19			FR
20			FR
21			FR
22			FR
23			FR
24			FR
25			FR
26			FR
27			FR
28			FR
29			FR
30			FR
31			FR
32
33		BIRD	CR
34		BIRD	CR
35		BIRD	CR
36		BIRD	CR
WPL

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

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

A tweak I think is needed ...

 

[Peter_SSs]

OK, now I understand better, I think
My previous approach is not suitable for your layout, so try this approach.

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