Page tree

Welcome to FreeSoftwareServers Confluence Wiki

Skip to end of metadata
Go to start of metadata

Test:

Sub MergeTest()
Dim wsrng As Range
Set wsrng = ActiveSheet.UsedRange
Call MergeWS(wsrng)
'Call UnMergeWS(wsrng)
End Sub

Merge:

https://www.extendoffice.com/documents/excel/1138-excel-merge-same-value.html

Function MergeWS(WorkRng As Range)
Dim Rng As Range, xCell As Range
Dim xRows As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
xRows = WorkRng.Rows.Count
For Each Rng In WorkRng.Columns
    For i = 1 To xRows - 1
        For j = i + 1 To xRows
            If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
                Exit For
            End If
        Next
        With WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1))
            .Merge
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
        i = j - 1
    Next
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function

UnMerge:

https://www.extendoffice.com/documents/excel/1139-excel-unmerge-cells-and-fill.html

Function UnMergeWS(WorkRng As Range)
Dim Rng As Range, xCell As Range
xTitleId = "KutoolsforExcel"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each Rng In WorkRng
    If Rng.MergeCells Then
        With Rng.MergeArea
            .UnMerge
            .Formula = Rng.Formula
        End With
    End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function



  • No labels