Un Merging Cells Using VBA

Sub Unmerge_CenterAcross()
'Erik Van Geit
'080808
 
'merged cells will be unmerged
'contents will be centered across merged area
 
Dim LR As Long      'Last Row
Dim LC As Integer   'Last Column
Dim i As Long
Dim j As Long
 
Dim cntUnmerged As Long
Dim cntMerged As Long
Dim mergeRng As Range
Dim checkmerged As Boolean
Dim LastMerged As String
 
Dim AppSetCalc As Integer
Dim StatusBarVisible As Boolean
 
Dim msg As String
Dim MaxRc As Long
Dim ColorMe As Boolean
 
 
    If ActiveWorkbook.Saved = False Then
    msg = "Your workbook is not saved." & vbNewLine
    msg = msg & "Code checks last used cell, which is only updated when saved" & vbNewLine & vbNewLine
    msg = msg & "Do want to save now?"
 
        If MsgBox(msg, 292, "SAVE?") = vbYes Then
        On Error Resume Next
        ActiveWorkbook.Save
            If Err Then
            MsgBox Err.Description, vbCritical, "ERROR " & Err.Number
            Exit Sub
            End If
        End If
 
    End If
 
    With ActiveSheet
    'needing xlCellTypeLastCell: else if last cell is merged wrong area will be found
    LR = .Cells.SpecialCells(xlCellTypeLastCell).Row
    LC = .Cells.SpecialCells(xlCellTypeLastCell).Column
        With .Cells(LR, LC)
            If .MergeCells Then
            LR = LR + .MergeArea.Rows.Count - 1
            LC = LC + .MergeArea.Columns.Count - 1
            End If
        End With
    If .Range(.Cells(1, 1), .Cells(LR, LC)).MergeCells = False Then
    MsgBox "no merged cells on this sheet", 48, "EXIT"
    Exit Sub
    End If
 
    msg = "Please define max # of rows a merged area may contain"
    msg = msg & "EXAMPLE" & vbNewLine & "If you type ""5"" then A1:A5 or A1:B5 will be unmerged, but not A1:A6"
    MaxRc = Application.InputBox(msg, "", 1, , , , , 1)
    If MaxRc = 0 Then Exit Sub
 
    msg = "Do you want to color the unmerged cells to check out the result?"
    ColorMe = MsgBox(msg, 292, "Color") = vbYes
 
    With Application
    .ScreenUpdating = False
    AppSetCalc = .Calculation
    .Calculation = xlCalculationManual
    StatusBarVisible = .DisplayStatusBar
    .DisplayStatusBar = True
    .EnableCancelKey = xlErrorHandler
    End With
 
    For i = 1 To LR
    On Error Resume Next
    checkmerged = .Range(.Cells(i, 1), .Cells(i, LC)).MergeCells
    'error occurs when MergeArea intersects row and contains more rows
    'checkmerged is TRUE when MergeArea is in one row
        If Err Or checkmerged Then
        Err.Clear
            For j = 1 To LC
                With .Cells(i, j)
                    If .Resize(1, 1).MergeCells Then
                    cntMerged = cntMerged + 1
                        On Error GoTo stopit
                        With .MergeArea
                            If .Rows.Count <= MaxRc Then
                            cntUnmerged = cntUnmerged + 1
                            .UnMerge
                            .HorizontalAlignment = xlCenterAcrossSelection
                            If ColorMe Then .Interior.ColorIndex = 3
                            Else
                            LastMerged = .Address(0, 0)
                            End If
                        End With
                    End If
                End With
            Next j
        End If
    Application.StatusBar = "rows checked: " & Round(i / LR, 2) * 100 & "%"
    Next i
 
    End With
 
stopit:
    With Application
    .EnableCancelKey = xlDisabled
    .ScreenUpdating = True
    .Calculation = AppSetCalc
    .StatusBar = False
    .DisplayStatusBar = StatusBarVisible
    End With
 
    If i > 0 Then
    msg = IIf(i = LR + 1, "All rows checked", "Last row checked: " & vbTab & i) & vbNewLine
    msg = msg & "Found areas: " & vbTab & cntMerged & vbNewLine
    msg = msg & "Unmerged areas: " & vbTab & cntUnmerged & vbNewLine
        If cntMerged <> cntUnmerged Then
        msg = msg & "Still merged: " & vbTab & cntMerged - cntUnmerged & vbNewLine & vbNewLine
        msg = msg & "Last area: " & LastMerged
        End If
    End If
 
    If Err Then msg = msg & Err.Description
    MsgBox msg, IIf(Err, vbCritical, vbOKOnly), IIf(Err, "ERROR " & Err.Number, "Done")
 
End Sub