Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 374
  • Last Modified:

Unmerge cell and split into rows

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
Watnog
Asked:
Watnog
  • 2
1 Solution
 
Patrick MatthewsCommented:
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

Open in new window

0
 
WatnogAuthor Commented:
Thank you very much, this makes my day.
0
 
cyberkiwiCommented:
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

Open in new window

0
 
WatnogAuthor Commented:
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

Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now