Solved

Unmerge cell and split into rows

Posted on 2010-08-20
Medium Priority
378 Views
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.
Thanks.
tobeunmerged.xls
0
Question by:Watnog
• 2
4 Comments

LVL 93

Accepted Solution

Patrick Matthews earned 2000 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

Worksheets.Add
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
Next
DestR = DestR + MaxRows
Next

MsgBox "Done"

End Sub
``````
0

Author Closing Comment

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

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)
Next
Set r = Cells.Find(Chr(10), r, , xlPart)
Wend
End Sub
``````
0

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)?
0

Featured Post

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment Already a member? Login.

This article describes how you can use Custom Document Properties to store settings and other information in your workbook so that they will be available the next time you open the workbook.
After seeing numerous questions for Dynamic Data Validation I notice that most have used Visual Basic to solve the problem. This suggestion is purely formula based and can be used in multiple rows.
This Micro Tutorial demonstrates using Microsoft Excel pivot tables, how to reverse engineer competitors' marketing strategies through backlinks.
Enter Foreign and Special Characters Enter characters you can't find on a keyboard using its ASCII code ... and learn how to make a handy reference for yourself using Excel ~ Use these codes in any Windows application! ... whether it is a Micrâ€¦
Suggested Courses
Course of the Month12 days, 12 hours left to enroll

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

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