Merge cell helper VBA (license: modified BSD)

merge-cell-helper.vba

Sub MergeSelectionAndSelectNext(vertical As Boolean)
    ' merge and select next area
    Dim selRange As Range
    Dim newRange As Range
    
    If TypeName(Selection) <> "Range" Then
        MsgBox "Please select some range (not " & TypeName(Selection) & ") and re-exec."
        Exit Sub
    End If
    
    Set selRange = Selection
    If selRange.Areas.Count <> 1 Then
        MsgBox "Please select simple range only (do not use ctrl) and re-exec."
        Exit Sub
    End If
    selRange.MergeCells = True
    If vertical Then
        Set newRange = selRange.Offset(1, 0)
    Else
        Set newRange = selRange.Offset(0, 1)
    End If
    Range(newRange, newRange.Offset(selRange.Rows.Count - 1, selRange.Columns.Count - 1)).Select
    Set selRange = Nothing
    Set newRange = Nothing
End Sub

Sub MergeSelectionAndSelectNextVertical()
    MergeSelectionAndSelectNext True
End Sub

Sub MergeSelectionAndSelectNextHorizontal()
    MergeSelectionAndSelectNext False
End Sub

Sub ExpandMergedCells(vertical As Boolean)
    ' expand merged cells; vertically or horizontally
    ' (vertical expand example)
    '  | A | B | C |       | A | B | C |
    '  +---+---+---+       +---+---+---+
    '  |       |bar|  -->  |  foo  |bar|
    '  |  foo  +---+       +-------+---+
    '  |       |baz|       |  foo  |baz|
    '  +-------+---+       +-------+---+
    
    Dim selRange As Range
    Dim newRange As Range
    Dim mergeArea As Range
    Dim i, j, k As Integer
    Dim content As Variant
    
    If TypeName(Selection) <> "Range" Then
        MsgBox "Please select some range (not " & TypeName(Selection) & ") and re-exec."
        Exit Sub
    End If
    
    Set selRange = Selection
    If selRange.Areas.Count <> 1 Then
        MsgBox "Please select simple range only (do not use ctrl) and re-exec."
        Exit Sub
    End If
    
    For i = 1 To selRange.Rows.Count
        For j = 1 To selRange.Columns.Count
            Set newRange = selRange.Cells(i, j)
            Set mergeArea = newRange.mergeArea
            If (vertical And mergeArea.Rows.Count <> 1) Or (Not vertical And mergeArea.Columns.Count <> 1) Then
                ' merge
                content = mergeArea.Value
                mergeArea.MergeCells = False
                If vertical Then
                    For k = 1 To mergeArea.Rows.Count
                        With Range(mergeArea.Cells(k, 1), mergeArea.Cells(k, mergeArea.Columns.Count))
                            .MergeCells = True
                            .Value = content
                        End With
                    Next
                Else
                    For k = 1 To mergeArea.Columns.Count
                        With Range(mergeArea.Cells(1, k), mergeArea.Cells(mergeArea.Rows.Count, k))
                            .MergeCells = True
                            .Value = content
                        End With
                    Next
                End If
            End If
            Set newRange = Nothing
            Set mergeArea = Nothing
        Next
    Next
    Set selRange = Nothing
End Sub

Sub ExpandMergedCellsVertical()
    ExpandMergedCells True
End Sub

Sub ExpandMergedCellsHorizontal()
    ExpandMergedCells False
End Sub