Help With Function to Merge Cells Automatically

bjw122 · Nov 14, 2005

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.

erik.van.geit · Nov 14, 2005

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 · Nov 14, 2005

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 · Nov 14, 2005

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 · Nov 14, 2005

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...

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 · Nov 14, 2005

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 · Nov 14, 2005

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.

Very nice indeed!

erik.van.geit · Nov 14, 2005

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

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

bjw122 · Nov 14, 2005

Thank you!

These functions are just what I needed. Thank you guys!

erik.van.geit · Nov 14, 2005

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

thank you for asking this intresting question, bjw122 !!!

God bless you!
Erik

Help With Function to Merge Cells Automatically

bjw122

New Member

Excel Facts

erik.van.geit

MrExcel MVP

HalfAce

MrExcel MVP

erik.van.geit

MrExcel MVP

HalfAce

MrExcel MVP

erik.van.geit

MrExcel MVP

HalfAce

MrExcel MVP

erik.van.geit

MrExcel MVP

bjw122

New Member

erik.van.geit

MrExcel MVP

Similar threads

Forum statistics

Share this page

Help With Function to Merge Cells Automatically

New Member

Excel Facts

MrExcel MVP

MrExcel MVP

MrExcel MVP

MrExcel MVP

MrExcel MVP

MrExcel MVP

MrExcel MVP

New Member

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock