Help With Function to Merge Cells Automatically

Status
Not open for further replies.

bjw122

New Member
Joined
Oct 3, 2005
Messages
16
If I have a worksheet that looks like this simplified version:

Column A
-----------
Value 1
Value 1
Value 1
Value 1
VALUE 2
VALUE 2
VALUE 2
Test
Test
Test
Test

And I want to be able to use a macro to merge cells that have the same value in column A to produce output like this:

Column A
-----------
Value 1
[Merged Cell]
[Merged Cell]
[Merged Cell]
VALUE 2
[Merged Cell]
[Merged Cell]
Test
[Merged Cell]
[Merged Cell]
[Merged Cell]

* Note that column A has rows 2 through 4 merged (as in 'Format Cells' --> 'Merge Cells') with row 1. Likewise, rows 5 through 7 are merged as well as rows 8 through 11.

The psedudocode to do this would look something like the following but I need help making this into working code:

Sub Merge_RowsX()
TgtStr As String, Dim i As Long, BeginRowNum As Integer,
EndRowNum As Integer (and additional variables as needed)

Application.ScreenUpdating = False

For i = 1 To [A65536].End(xlUp).Row

1.] Get the value of first cell in column A
* Store TgtStr
* Store BeginRowNum
2.] Iterate through subsequent rows in column A until value is different from TgtStr
* Store EndRowNum
3.] Merge cells BeginRowNum to EndRowNum

Next i Repeat loop (i.e. get new TgtStr)

Application.ScreenUpdating = True
End Sub

Any help is greatly appreciated, I hope my explanation is clear.
 

Some videos you may like

Excel Facts

Easy bullets in Excel
If you have a numeric keypad, press Alt+7 on numeric keypad to type a bullet in Excel.

erik.van.geit

MrExcel MVP
Joined
Feb 1, 2003
Messages
17,832
Hello, bjw122,
try this code
it's a FAST LOOP (using the inbuiltfunction "columndifferences") instead of "Iterate through subsequent rows in column A until value is different from TgtStr"
set the column and the first row before running
Const col = 1
Const FR = 2
Code:
Option Explicit

Sub merge_same_data()
'Erik Van Geit
'050802 0337
'merge cells with same contents in single column

Dim Lcell As Range
Dim cell As Range
Dim i As Long

Const col = 1
Const FR = 2

Set Lcell = Cells(65536, col).End(xlUp)
Set cell = Cells(FR, col)
Lcell.Offset(1, 0) = "' " & Lcell

With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

  Do
  i = cell.Row
  Set cell = Range(cell, Lcell.Offset(1, 0)).ColumnDifferences(cell)(1)
  Range(Cells(i, col), Cells(cell.Row - 1, col)).Merge
  If cell.Row > Lcell.Row Then Exit Do
  Loop
  
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With

Lcell.Offset(1, 0) = ""

End Sub
kind regards,
Erik

EDIT: deleted two unnecessary lines
 

HalfAce

MrExcel MVP
Joined
Apr 6, 2003
Messages
9,453
Hello bjw122,
Looks like Erik beat me to it while I got called away for a bit, but here's a loop that's (slightly) faster, although it requires your data to be sorted where all the values are consecutive as in your example. The beauty of Erik's solution is that that's not necessary. (That's nice.)
Code:
Sub MergeColA()
Dim c As Range, A As Range
Dim RwsToMrg As Long
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

Set A = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))

For Each c In A
    RwsToMrg = Application.WorksheetFunction.CountIf(A, c)
    If RwsToMrg > 1 Then
      With c.Resize(RwsToMrg, 1)
        .Merge
        .VerticalAlignment = xlCenter
      End With
    End If
Next c

With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
End Sub
If you want the value(s) to appear at the top of the merged cells, you can change the line:
.VerticalAlignment = xlCenter
to:
.VerticalAlignment = xlTop

(This can also be added to Erik's fine solution too.)
Hope it helps.
Dan
 

erik.van.geit

MrExcel MVP
Joined
Feb 1, 2003
Messages
17,832
Hi, Dan,
I love your style!
When someone talkes about speed (slightly faster) my ears are very attentive and my mind is allerted :)
did you see my code is not looping through all cells, but is jumping from one difference to the other ?
Code:
Set cell = Range(cell, Lcell.Offset(1, 0)).ColumnDifferences(cell)(1)
anyway yours must be faster - if anyway OP allows sorted column - since it is not defining cells which is "very slow"

on a large range my code is also very slow since it is finding all differences while you need only the first

I'll try a memory-array-solution

God bless you!
Erik
 

HalfAce

MrExcel MVP
Joined
Apr 6, 2003
Messages
9,453

ADVERTISEMENT

erik.van.geit said:
did you see my code is not looping through all cells, but is jumping from one difference to the other ?
Code:
Set cell = Range(cell, Lcell.Offset(1, 0)).ColumnDifferences(cell)(1)
Good morning Erik. (Porbably evening for you eh?)
Yes I did see how you were jumping from one difference to the next, (I like that), and was indeed surprised to find that going through each cell yielded quicker results. (I was testing them side by side on a range of a little over 1500 rows of repeating sections of "Value 1", "Value 2" & "Value 3".) Below are the two routines as tested. Like I said, I was surprised your method was not the quicker of the two. Seems to me it should be... :unsure:
Code:
Sub MergeColA()
strt = Timer
Dim c As Range, A As Range
Dim RwsToMrg As Long
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

Set A = Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))

For Each c In A
    RwsToMrg = Application.WorksheetFunction.CountIf(A, c)
    If RwsToMrg > 1 Then
      With c.Resize(RwsToMrg, 1)
        .Merge
        .VerticalAlignment = xlCenter
      End With
    End If
Next c

With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
stp = Timer
[d65536].End(xlUp)(2, 1) = stp - strt
End Sub

Sub merge_same_data()
strt = Timer
Dim Lcell As Range
Dim cell As Range
Dim i As Long
Dim HL As Integer 'highlightcolor

Const col = 1
Const FR = 2

Set Lcell = Cells(65536, col).End(xlUp)
Set cell = Cells(FR, col)
Lcell.Offset(1, 0) = "' " & Lcell

With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

  Do
  i = cell.Row
  Set cell = Range(cell, Lcell.Offset(1, 0)).ColumnDifferences(cell)(1)
  Range(Cells(i, col), Cells(cell.Row - 1, col)).Merge
  If cell.Row > Lcell.Row Then Exit Do
  Loop
 
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With

Lcell.Offset(1, 0) = ""
Application.ScreenUpdating = True
stp = Timer
[c65536].End(xlUp)(2, 1) = stp - strt
End Sub
 

erik.van.geit

MrExcel MVP
Joined
Feb 1, 2003
Messages
17,832
EDIT: oh, you posted also :)
mine is slower as said while on a large range my code is also very slow since it is finding all differences while you need only the first

Here is some new code :)
how about this when you test it ?
tested on entire column, so 65536 items (4 year old machine, several programs open)
1. with about 43000 "singles" : about 40 sec
2. with 6536 "changes" : about 25 sec
Code:
Option Explicit
Option Base 1

Sub merge_same_data()
'Erik Van Geit
'050802 0337
'merge cells with same contents in single column

Dim rng As Range
Dim LR As Long
Dim i As Long
Dim j As Long
Dim Arr As Variant
Dim ArrItem As String
Dim ArrRowNumbers() As Variant

Const col = 1
Const FR = 2

LR = Cells(Rows.Count, col).End(xlUp).Row
Set rng = Range(Cells(FR, col), Cells(LR, col))

Arr = rng.Value
i = FR - 1
    Do
    ArrItem = Arr(i, 1)
        On Error Resume Next 'avoids bug at the end of the loop "Arr(i, 1)" when i > UBound(arr)
        Do
        i = i + 1
        Loop While ArrItem = Arr(i, 1)
        On Error GoTo 0
    j = j + 1
    ReDim Preserve ArrRowNumbers(j)
    ArrRowNumbers(j) = i
    Loop While i < LR

  
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

Range(Cells(FR, col), Cells(ArrRowNumbers(1), col)).Merge
For i = 2 To j
Range(Cells(ArrRowNumbers(i - 1) + 1, col), Cells(ArrRowNumbers(i), col)).Merge
Next i

With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With

End Sub
avoiding to merge cells which anyway will stay alone would still enhance this ... (see if I can resist to try it out)
kind regards,
Erik
 

HalfAce

MrExcel MVP
Joined
Apr 6, 2003
Messages
9,453

ADVERTISEMENT

Whoa, wait a minute. I stand corrected, big time.
When I run your original code against mine on a range of 1500 + rows, without sorting the values to be consecutive, my code ran a little faster.
When I run the same test after sorting the values to be consecutive, your code ran MUCH faster, so with the OP's original example, the .ColumnDifferences method would be far preferable.

Your latest code runs much faster than anything else in either condition.
:LOL:

Very nice indeed!
 

erik.van.geit

MrExcel MVP
Joined
Feb 1, 2003
Messages
17,832
the .ColumnDifferences method would be far preferable.
not when you will run this one :) :)
as you could imagine, I didn't resist to do this job till the end :p
this is skipping all singles
so the test will be without singles
generating testdata
Code:
Sub fillit()
For i = 1 To 65500 Step 25
Range("A" & i & ":A" & i + 24) = i
Next i
End Sub

this code did the job in 4 seconds
on your machine perhaps 2 ?
Code:
Option Explicit
Option Base 1

Sub merge_same_data()
'Erik Van Geit
'050802 0337
'merge cells with same contents in single column
'skip "singles" to make code faster

Dim rng As Range
Dim LR As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim Arr As Variant
Dim ArrItem As String
Dim ArrRowNumbers() As Variant

Const col = 1
Const FR = 2

If Cells(Rows.Count, col) <> "" Then LR = Rows.Count Else LR = Cells(Rows.Count, col).End(xlUp).Row
Set rng = Range(Cells(FR, col), Cells(LR, col))

Arr = rng.Value
i = 1
j = 1
    Do
    ArrItem = Arr(i, 1)
    k = i
        On Error Resume Next 'avoids bug at the end of the loop "Arr(i, 1)" when i > UBound(arr)
        Do
        i = i + 1
        Loop While ArrItem = Arr(i, 1)
        On Error GoTo 0
            If k <> i - 1 Then
            ReDim Preserve ArrRowNumbers(j + 1)
            ArrRowNumbers(j) = k + FR - 1
            ArrRowNumbers(j + 1) = i - 1 + FR - 1
            j = j + 2
            End If
    Loop While i < LR

  
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With

For i = 1 To j - 1 Step 2
Range(Cells(ArrRowNumbers(i), col), Cells(ArrRowNumbers(i + 1), col)).Merge
Next i

With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With

End Sub

best regards,
Erik
EDIT: to be sure it works also with singles I added some for the test
Code:
Sub fillit()
For i = 1 To 65500 Step 25
Range("A" & i & ":A" & i + 24) = i
Range("A" & i) = "single :-)"
Next i
End Sub
 

erik.van.geit

MrExcel MVP
Joined
Feb 1, 2003
Messages
17,832
These functions are just what I needed. Thank you guys!
hopefully you will try to understand how it works, at least some parts :)
I can imagine this thread isn't finished, since we started an expertise of runtime :p
thank you for asking this intresting question, bjw122 !!!

God bless you!
Erik
 
Status
Not open for further replies.

Watch MrExcel Video

Forum statistics

Threads
1,118,799
Messages
5,574,379
Members
412,589
Latest member
ArtBOM
Top