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