Select all unmerge copy contents

i8lunch

New Member
Joined
Sep 25, 2006
Messages
4
I have a large amount of data that I need to unmerge. Unfortunately when unmerging in the traditional manner the content of all-but-one cell are deleted. :confused:

Is anyone aware of a tool that will unmerge cells and copy the data into each of the unmerged cells?
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Hi, i8lunch
Welcome to the Board !!!!!

I'm not aware of any tool (often not aware of what happens in the world anyway :) ), but reinventing the wheel is a nice occupation :LOL:

so try this
Code:
Option Explicit

Sub unmerge_fill_values()
'Erik Van Geit
'060925

'unmerge and put value in mergearea
'EXAMPLE
'START WITH
'D1:E3 merged, value = "abc"
'RESULT
'D1:E3 unmerged, D1, D2, D3, E1, E2, E3 get "abc"

Dim LR As Long      'Last Row
Dim LC As Integer   'Last Column
Dim i As Long
Dim j As Integer
Dim mergeRng As Range
Dim checkmerged As Boolean
Dim AppSetCalc As Integer

    With Application
    .ScreenUpdating = False
    AppSetCalc = .Calculation
    .Calculation = xlCalculationManual
    End With

    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

    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)
                Set mergeRng = .MergeArea
                .UnMerge
                mergeRng = .Value
                End With
            Next j
        End If
    Next i
    
    End With

    With Application
    .ScreenUpdating = True
    .Calculation = AppSetCalc
    End With

End Sub
enjoy the Board !!

kind regards,
Erik
 
Upvote 0
update

if you have more then one worksheet

Special thanks to Erik Van Geit



Option Explicit

Sub UnMergeWorkbook()
'Simon Tremblay

Dim xlSheet As Worksheet
Application.ScreenUpdating = False

For Each xlSheet In Worksheets
Call unmerge_fill_values(xlSheet)
Next xlSheet
Application.ScreenUpdating = True
ThisWorkbook.Save 'if you would test just put this line in comment
End Sub



Public Sub unmerge_fill_values(ByVal xlSheet As Worksheet) 'obj As String
'Erik Van Geit
'Little modification Simon Tremblay

Dim LR As Long 'Last Row
Dim LC As Integer 'Last Column
Dim i As Long
Dim j As Integer
Dim mergeRng As Range
Dim checkmerged As Boolean
Dim AppSetCalc As Integer

MsgBox xlSheet.Name 'Just to see which worksheet is updating

With Application
.ScreenUpdating = False
AppSetCalc = .Calculation
.Calculation = xlCalculationManual
End With

With xlSheet ' xlSheet parameter replace 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

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)
Set mergeRng = .MergeArea
.UnMerge
mergeRng = .Value
End With
Next j
End If
Next i

End With

With Application
.ScreenUpdating = True
.Calculation = AppSetCalc
End With

End Sub

*Sorry for the indent
 
Upvote 0
Hi, SubFire
Welcome to the Board !!!!!

It would be nice if you used the CODEbutton. The code would be well indented.
Click "EDIT" above your post.
Select the code.
Click "CODE" button.
Submit.

Done :biggrin:

enjoy the Board!!
Erik
 
Upvote 0
Re: update

if you have more then one worksheet

Special thanks to Erik Van Geit


Code:
Option Explicit

Sub UnMergeWorkbook()
'Simon Tremblay

Dim xlSheet As Worksheet
Application.ScreenUpdating = False

    For Each xlSheet In Worksheets
         Call unmerge_fill_values(xlSheet)
    Next xlSheet
Application.ScreenUpdating = True
ThisWorkbook.Save 'if you would test just put this line in comment
End Sub



Public Sub unmerge_fill_values(ByVal xlSheet As Worksheet) 'obj As String
'Erik Van Geit
'Little modification Simon Tremblay

Dim LR As Long      'Last Row
Dim LC As Integer   'Last Column
Dim i As Long
Dim j As Integer
Dim mergeRng As Range
Dim checkmerged As Boolean
Dim AppSetCalc As Integer

MsgBox xlSheet.Name 'Just to see which worksheet is updating

    With Application
    .ScreenUpdating = False
    AppSetCalc = .Calculation
    .Calculation = xlCalculationManual
    End With

    With xlSheet ' xlSheet  parameter replace 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

    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)
                Set mergeRng = .MergeArea
                .UnMerge
                mergeRng = .Value
                End With
            Next j
        End If
    Next i
    
    End With

    With Application
    .ScreenUpdating = True
    .Calculation = AppSetCalc
    End With

End Sub


*Sorry for the indent
 
Upvote 0
DISCOVERED A LOGIC ERROR
There was an Exit Sub "after" setting calculation to manual
When there are no merged cell, you are left with manual calculation
This is te correction
Code:
Option Explicit
 
Sub unmerge_fill_values()
'Erik Van Geit
'060925
 
'unmerge and put value in mergearea
'EXAMPLE
'START WITH
'D1:E3 merged, value = "abc"
'RESULT
'D1:E3 unmerged, D1, D2, D3, E1, E2, E3 get "abc"
 
Dim LR As Long      'Last Row
Dim LC As Integer   'Last Column
Dim i As Long
Dim j As Integer
Dim mergeRng As Range
Dim checkmerged As Boolean
Dim AppSetCalc As Integer
 
    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

    With Application
    .ScreenUpdating = False
    AppSetCalc = .Calculation
    .Calculation = xlCalculationManual
    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)
                Set mergeRng = .MergeArea
                .UnMerge
                mergeRng = .Value
                End With
            Next j
        End If
    Next i
    
    End With
    With Application
    .ScreenUpdating = True
    .Calculation = AppSetCalc
    End With
 
End Sub
 
Upvote 0
THis is awesome! Thanks so much - this is a big help in formatting the reports that our system spits out.
 
Upvote 0

Forum statistics

Threads
1,213,483
Messages
6,113,919
Members
448,533
Latest member
thietbibeboiwasaco

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top