CODEWITHSUNDEEP
vbaexcelmerge
user7410879
user7410879

Reputation: 25

Merge, Unmerge, Remerge macro

I am working on a macro to unmerge merged cells in a given range and then re merge the original merged cells which were unmerged. I have been struggling to identify how to store a list of the cells which are initially unmerged so that the macro can re merge those exact cells.The rows that are merged in the spreadsheet change from week to week. 

Sub MergeUnmerge()

'

Mergeunmerge Macro
'

Dim mergelist As Range

Dim celllist As Range


For Each cell In Range("A1:S49")

If cell.MergeCells = True Then
   Set mergelist = celllist
            cell.UnMerge
        End If
    Next

 For Each cell In mergelist
    Range("celllist").Merge
Next

End Sub

Upvotes: 2

Views: 2265

Answers (2)

Chrismas007
Chrismas007

Reputation: 6105

You'll need to add the MergeArea address to an array.

Sub MergeUnmerge()

Dim cel As Range
Dim mergeArr()  
y = 0

For Each cel In Range("A1:S49")
    If cel.MergeCells = True Then
        ReDim Preserve mergeArr(y + 1)
        mergeArr(y + 1) = cel.MergeArea.Address
        cel.UnMerge
        y = y + 1
    End If
Next cel

For x = 1 To y
    Range(mergeArr(x)).Merge
Next x

End Sub

Upvotes: 4

user3598756
user3598756

Reputation: 29421

you have to:

  • use mergeCells property to check for merged cells

  • use Areas property of Range object

  • use Merge method to merge areas back

like follows

Option Explicit

Sub MergeUnmerge()
    Dim mergedCells As Range
    Dim cell As Range

    With Range("A1:S49") '<--| reference your range
        Set mergedCells = .Offset(.Rows.Count, .Columns.Count).Resize(1, 1) '<--| initialize mergedCells range to a spurious cell out of referenced range
        For Each cell In .Cells '<--|loop through referenced range cells
            If cell.mergeCells Then '<--| if current cell belongs to a merged area
                Set mergedCells = Union(mergedCells, cell.MergeArea) '<--| update 'mergedCells' range
                cell.UnMerge '<--| unmerge it
            End If
        Next

        Set mergedCells = Intersect(mergedCells, .Cells) '<--| filter out the spurious cell
        If Not mergedCells Is Nothing Then '<--| if there's some cell left
            For Each cell In mergedCells.Areas '<--| loop through areas
                cell.Merge '<--| merge curent area
            Next
        End If
    End With
End Sub

Upvotes: 1

Related Questions