macro vba, remove all merge cell

Option Explicit

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