1

I am trying to write a simple thing that will merge cells in excel with the same information. What I've got thus far is what follows:

Private Sub MergeCells()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim rngMerge As Range, cell As Range
    Set rngMerge = Range("B2:B1000") 'Set the range limits here
    Set rngMerge2 = Range("C2:C1000")

MergeAgain:

    For Each cell In rngMerge
        If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
            Range(cell, cell.Offset(1, 0)).Merge
            GoTo MergeAgain
        End If
    Next

    Application.DisplayAlerts = False
    Application.ScreenUpdating = True


    For Each cell In rngMerge2
        If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
            Range(cell, cell.Offset(1, 0)).Merge
            GoTo MergeAgain
        End If
    Next

    Application.DisplayAlerts = False
    Application.ScreenUpdating = True

End Sub

So the problem I'm encountering is split into two issues, First I'm trying to get this to work for columns A - AK but as you can see above I don't know how to combine it without just making it repeat the same thing 30 times over. Is there another way to group it.

Also when I assign the range to Range("AF2:AF1000") and Range("AG2:AG1000") then excel in its entirety crashes. I was hoping you all could help steer me into the right direction.

Improve this question
4
  • 1
    My view is that merged cells raise a LOT of problems and should be avoided at all costs. I just wrote something this morning to change all merged ranges in a sheet into center across selection to get rid of that crap. Commented Jul 3, 2018 at 12:08
  • 1
    @PatrickHonorez you should consider posting it to Code Review. Commented Jul 3, 2018 at 13:08
  • @PatrickHonorez what would something like that look like, because I do recognise that merged cells often make a sheet look like shite but the people above me don't recognise an alternative. I haven't seen what a centre across selection would even look like, care to share :) Commented Jul 3, 2018 at 13:53
  • @TinMan done: codereview.stackexchange.com/q/197726/9156 Commented Jul 3, 2018 at 14:03

4 Answers 4

Reset to default
2

Repeat code inside a subroutine is a sign that some of the routines functionality should be extracted into its own method.

Performance

1000 seems like an arbitrary row: Range("B2:B1000"). This range should be trimmed to fit the data.

It is better to Union all the cells to be merged and merge them in a single operation.

Application.DisplayAlerts does not need to be set to True. It will reset after the subroutine has ended.

Public Sub MergeCells()
    Dim Column As Range
    Application.ScreenUpdating = False

    With ThisWorkbook.Worksheets("Sheet1")
        For Each Column In .Columns("A:K")
            Set Column = Intersect(.UsedRange, Column)
            If Not Column Is Nothing Then MergeEqualValueCellsInColumn Column
        Next
    End With

    Application.ScreenUpdating = True
End Sub

Sub MergeEqualValueCellsInColumn(Target As Range)
    Application.DisplayAlerts = False
    Dim cell As Range, rMerge As Range
    For Each cell In Target
        If cell.Value <> "" Then
            If rMerge Is Nothing Then
                Set rMerge = cell
            Else
                If rMerge.Cells(1).Value = cell.Value Then
                    Set rMerge = Union(cell, rMerge)
                Else
                    rMerge.Merge
                    Set rMerge = cell
                End If
            End If
        End If
    Next
    If Not rMerge Is Nothing Then rMerge.Merge
End Sub

enter image description here

Improve this answer
Sign up to request clarification or add additional context in comments.

Comments

1

You keep modifying the cells in rngMerge but not the definition of it before reusing it. This would likely work better if you started at the bottom and worked up as the situation is similar to inserting or deleting rows.

Option Explicit

Private Sub MergeCells()

    Dim i As Long, c As Long, col As Variant

    Application.DisplayAlerts = False
    'Application.ScreenUpdating = false

    col = Array("B", "C", "AF", "AG")

    For c = LBound(col) To UBound(col)
        For i = Cells(Rows.Count, col(c)).End(xlUp).Row - 1 To 2 Step -1
            If Cells(i, col(c)).Value = Cells(i, col(c)).Offset(1, 0).Value And Not IsEmpty(Cells(i, col(c))) Then
                Cells(i, col(c)).Resize(2, 1).Merge
                Cells(i, col(c)).HorizontalAlignment = xlCenter
                Cells(i, col(c)).VerticalAlignment = xlCenter
            End If
        Next i
    Next c

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

I've added a wrapping loop that cycles through multiple columns pulled from an array.

I've also notice the Private nature of the sub procedure and I'm guess that this is in a worksheet's private code sheet (right-click name tab, View Code). If the code is to be run on multiple worksheets, it belongs in a public module code sheet (in the VBE use Insert, Module) and proper parent worksheet references should be added to the Cells.

Improve this answer

8 Comments

I like the use of the Array of Columns. I would prefer For Each col in Array("B", "C", "AF", "AG").
Yeah, @TinMan - I'm not much of a For Each style code writer but that would be a perfectly acceptable modification if that style makes more sense.
how would one modify this so that the array includes all cells from A to AK, would you manually input them all into the col = Array() or is there a shortcut to say A - AK
Change the For c = LBound(col) To UBound(col) to For c = columns("A").column To columns("AK").column then replace each Cells(i, col(c)) with Cells(i, c).
Sorry last question about this part of the whole thing but what would be the cleanest way to make it merge A - U and then AA - Ak. Cause I can just double the code for it but I think thats a rather ineloquent way of doing it and would probably make for a relatively slow code.
|
1

It appears you are running the same procedure on rngMerge and rngMerge2, and that they are the same size.

I suggest the following, where you just iterate through the columns, and then through the cells in each column:

Option Explicit
Private Sub MergeCells()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim rngMerge As Range, cell As Range
    Dim rngFull As Range

    Set rngFull = Range("B2:AK1000")
    For Each rngMerge In rngFull.Columns
        For Each cell In rngMerge.Cells
            If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
                Range(cell, cell.Offset(1, 0)).Merge
                'Add formatting statements as desired
            End If
        Next cell
    Next rngMerge

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

NOTE As written, this will only handle duplicates. If you have triplets or more, only pairs of two will be combined.

Improve this answer

2 Comments

If you are going top to bottom (For Each cell In rngMerge.Cells) won't there be a problem with three or more duplicates without using .MergeArea on the cell? It seems to turn 4 identical into 2 @ 2 row merged cells.
@Jeeped Yes, you are correct. I was addressing the "looping through the rows issue, and did not consider triplets since he didn't mention it as a problem. I will edit my response
1

I would frame the problem a bit differently. Your code goes through each cell in the range, compares it to the next cell, and, if the values of the two are equivalent, then merge them together. I think it a bit clearer to check each cell against the previous cell value instead.

Also, you can iterate over the columns in order to avoid code repetition (as mentioned in other answers).

Sub MergeCells()
    Dim wks As Worksheet
    Dim mergeRange As Range
    Dim column As Range
    Dim cell As Range
    Dim previousCell As Range

    'Because the Sheets property can return something other than a single worksheet, we're storing the result in a variable typed as Worksheet
    Set wks = Sheets("Sheet1")

    'To run this code across the entire "used part" of the worksheet, use this:
    Set mergeRange = wks.UsedRange
    'If you want to specify a range, you can do this:
    'Set mergeRange = wks.Range("A2:AK1000")

    For Each column In mergeRange.Columns
        For Each cell In column.Cells
            If cell.Row > 1 Then
                'cell.Offset(-1) will return the previous cell, even if that cell is part of a set of merged cells
                'In that case, the following will return the first cell in the merge area
                Set previousCell = cell.Offset(-1).MergeArea(1)

                If cell.Value = previousCell.Value And Not IsEmpty(cell) Then
                    cell.Value = ""
                    wks.Range(previousCell, cell).Merge
                End If
            End If
        Next
    Next
End Sub

If you want to run this code on multiple ranges, you can isolate the code which carries out the merges within a range, into its own Sub procedure:

Sub MergeCellsInRange(mergeRange As Range)
    For Each column In mergeRange.Columns
        For Each cell In column.Cells
            If cell.Row > 1 Then
                Set previousCell = cell.Offset(-1).MergeArea(1)
                If cell.Value = previousCell.Value And Not IsEmpty(cell) Then
                    cell.Value = ""
                    wks.Range(previousCell, cell).Merge
                End If
            End If
        Next
    Next
End Sub

and call it multiple times from your main procedure:

Sub MergeCells()
    Dim wks As Worksheet
    Dim mergeRange As Range
    Dim column As Range
    Dim cell As Range
    Dim previousCell As Range

    Set wks = Sheets("Sheet1")

    MergeRange wks.Range("A2:U1000")
    MergeRange wks.Range("AA2:AK1000")
End Sub

References:

Excel object model

VBA

Improve this answer

Comments

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.