Un Merging Cells Using VBA

[DaddyH]

Hi guys, i am or was trying to do something that i thought would be quite simple. But am now pulling my hair out over it.

Quite simply here is what i am trying to do:
- I download a report from the system straight into excel (works fine)
- The spreadie has lots of columns which has merged cells (ie A & B are merged E & F are merged, G & H are merged and so on!!
- Then i start a macro and highlight the whole spreadsheet and press the "Merge & Center" button on the Home page
- Then Stop Macro!!!
Simple eh!!! No!!!!!!!!!!!!!
- When i try to re-run the macro i get a message that the macro is too large, upon looking at it the macro is over 32,000 lines long this is how the macro looks at the start:

Range("C2").Select
Sheets("AffiliatePlayerListReport ").Select
Columns("A:V").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

This script goes on and on exactly the same too the bottom.

Is there some simple script i can use to highlight a spreadsheet and un merge all cells?

Cheers

DaddyH

 

[VoG]

Try this http://www.mrexcel.com/forum/showthread.php?t=335123&highlight=unmerge

 

[DaddyH]

Hi Thanks for the response. But which bits should i be using / trying?

 

[VoG]

Run Unmerge_CenterAcross

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

 

[DaddyH]

Excellent! Thank you very much!!!

Very Clever!

Thanks a million!