Unmerge cell and split into rows

Posted on 2010-08-20
Last Modified: 2012-05-10
Hi dear Experts,

I've been searching for a while but could not lay my finger on a ready answer.
In attached sheet data is organized per row, some cells icontain merged data.
In order to work with that data those values should be unmerged and spllit into rows.
The relevant column is B. It has a pendant in column G. Merged data in other cells can be unmerged too if that would simplify things a bit.
I hope the example makes things clear, and also that this is possible.
Question by:Watnog
  • 2
LVL 92

Accepted Solution

Patrick Matthews earned 500 total points
ID: 33483617
Assuming that you have headings in Row 1 for all the columns you car about, this seems to be working.  It "unmerges" all of the cells.  (The cells are not truly merged in the Excel sense, of course...)
Sub RedoList()


    Dim LastR As Long, LastC As Long

    Dim arr As Variant

    Dim r As Long, c As Long

    Dim CellContents As Variant

    Dim MaxRows As Long

    Dim DestR As Long


    With ActiveSheet

        LastR = .Cells(.Rows.Count, 1).End(xlUp).Row

        LastC = .Cells(1, .Columns.Count).End(xlToLeft).Column

        arr = .Range(.Cells(1, 1), .Cells(LastR, LastC)).Value

    End With



    DestR = 1


    For r = 1 To UBound(arr, 1)

        MaxRows = 0

        For c = 1 To UBound(arr, 2)

            If arr(r, c) <> "" Then

                CellContents = Split(arr(r, c), Chr(10))

                Cells(DestR, c).Resize(UBound(CellContents) + 1, 1) = Application.Transpose(CellContents)

                If (UBound(CellContents) + 1) > MaxRows Then MaxRows = (UBound(CellContents) + 1)

            End If


        DestR = DestR + MaxRows



    MsgBox "Done"


End Sub

Open in new window


Author Closing Comment

ID: 33483787
Thank you very much, this makes my day.
LVL 58

Expert Comment

ID: 33483789
This code goes against the Sheet, it is not meant for a module since it works on current sheet only.
Sub unmergeme()

Dim lastRow As Long, extent As Long, r As Range

Dim s As String, parts() As String, i As Integer

lastRow = 0

Set r = Cells.Find(Chr(10), UsedRange.SpecialCells(xlCellTypeLastCell), , xlPart)

While Not r Is Nothing

    If r.Row <> lastRow Then extent = 1: lastRow = r.Row

    parts = Split(r.Value, Chr(10))

    If UBound(parts) + 1 > extent Then

        r.Offset(extent).Resize(UBound(parts) + 1 - extent).EntireRow.Insert

        extent = UBound(parts) + 1

    End If

    For i = 0 To UBound(parts)

        r.Offset(i).Value = parts(i)


    Set r = Cells.Find(Chr(10), r, , xlPart)


End Sub

Open in new window


Author Comment

ID: 33483863
I pasted the code into into a new module of my personal.xls and it works fine.
It should only work on current sheet in fact.
Excuse me my ignorance, but what makes code suitable for a module (or not)?

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

This tutorial explains how to create a series of drop-down lists that are dependent upon prior selections to guide (“force”) the user to make the correct selection and reduce data errors within Microsoft Excel. Excel 2010 was used for this tutorial;…
Enums (shorthand for ‘enumerations’) are not often used by programmers but they can be quite valuable when they are.  What are they? An Enum is just a type of variable like a string or an Integer, but in this case one that you create that contains…
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

707 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

19 Experts available now in Live!

Get 1:1 Help Now