Split multiple rows of data within a single cell

[PivotIdiot]

Hi All,

I'd like to create a macro that runs on selected cells in a given row.
There are usually only 4 cells in that row with data.
The data within each cell is on separate 'lines' within each cell, eg:

10 20 30 40

A B C D

Bob John Harry Seb

Jane Sarah Daisy Emma

I'd like the macro to separate the data in to individual rows, these rows must be inserted below as there are rows with viable data below, eg:

10	A	Bob	Jane
20	B	John	Sarah
30	C	Harry	Daisy
40	D	Seb	Emma

I've seen a couple of examples that i can work with but it'll take me an age to get it to work how i want and I know you people deal with vba all the time.
Can anyone help?

Massive thanks in advance

 

[maabadi]

Please Upload Example file with XL2BB ADDIN(Preferable) or upload at free hosting Site e.g. www.dropbox.com , GoogleDrive or OneDrive & insert Link here.
To we see with what characters lines Created in the Cells.

 

[maabadi]

Try This. Change colArray = Array("A", "B") to Columns you want Split e.g. colArray = Array("A", "B", "C", "D")
This Macro Paste Results at the Same Columns of Source file.

Option Explicit
Public Sub separate_line_break()
Dim colArray As Variant, check_col As Variant, ColLastRow As Long, Rng As Range, Rng2 As Range
Dim i As Long, c As Variant, currentrng As Range, upperRng As Range, ColLastRow2 As Long
    colArray = Array("A", "B")   'Define what columns you want to split
    check_col = colArray(0)
    ColLastRow = Range(check_col & Rows.Count).End(xlUp).Row
    Application.ScreenUpdating = False
    For Each Rng In Range(check_col & "1" & ":" & check_col & ColLastRow)
        If InStr(Rng.Value, vbLf) Then
            Rng.EntireRow.Copy
            Rng.EntireRow.Insert
            
            For i = 0 To UBound(colArray)
                c = colArray(i)
                
                Set currentrng = Range(c & Rng.Row)
                Set upperRng = currentrng.Offset(-1, 0)
            
                upperRng.Value = Mid(currentrng.Value, 1, InStr(currentrng.Value, vbLf) - 1)
                currentrng.Value = Mid(currentrng.Value, Len(upperRng.Value) + 2, Len(currentrng.Value))
            Next i
        End If
    Next
    
    ColLastRow2 = Range(check_col & Rows.Count).End(xlUp).Row
    For Each Rng2 In Range(check_col & "1" & ":" & check_col & ColLastRow2)
        If Len(Rng2) = 0 Then
            Rng2.EntireRow.Delete
        End If
    Next
    Application.ScreenUpdating = True
End Sub

 

[PivotIdiot]

Many thanks for taking the time to reply -

This is the Addin output for my data set....

Book1
	A	B	C	D	E	F
1	0.18	7.0 8.2 9.4 9.9	240 205 182 173	195.24* 166.59 145.67 138.39	12900 13000 13000 13000	3.4 3.9 4.5 4.7
2	0.18	4.6	375	199.81	9490	1.60
3	0.18	5.0	345	184.07	9660	1.75
4	0.18	5.8	295	158.14	9900	2.0
Sheet1

I changed the colArray to colArray = ActiveCell.Offset(0, 0).Range("A1:E1").Select

when i run the macro with cell B1 selected i get 'Type mismatch' error?

If i paste the cells into MSWord and show hidden formats i get this....

 

[maabadi]

Why change? In colArray only you need to input column Name with Comma Not Range, e.g. "A" , "B" , "C"
Why offset?

 

[PivotIdiot]

Why change? In colArray only you need to input column Name with Comma Not Range, e.g. "A" , "B" , "C"
Why offset?

I thought you meant i had to define the range i wanted to split

 

[maabadi]

No. It paste data at same columns and rows after of each row has line breaks and paste next line in it. Then you need only column letter that you want split.

 

[PivotIdiot]

So i couldnt get this to work and looked on google for answers.

Found a version of this that did exactly what i wanted....

Option Explicit
Sub Macro21()
'  http://wwww.mvps.org/dmcritchie/excel/crlf.htm
'  --look for Chr(10) from bottom
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual

    Dim i As Long, j As Long, k As Long
    For i = Cells(Cells.Rows.Count, "A").End(xlUp).Row _
                      To 2 Step -1
      j = Len(Cells(i, 2)) - Len(Replace(Cells(i, 2), _
                            Chr(10), "")) / Len(Chr(10))
      If j > 0 Then
        Rows(i + 1).Resize(j).Insert
        For k = 0 To j - 1
          '-- column A  maybe should be divided up
          '--     instead of copied ??
          Cells(i + k + 1, 1) = Cells(i, 1)
          '-- column B
          Cells(i + k + 1, 2) = Mid(Cells(i + k, 2), _
             InStr(1, Cells(i + k, 2), _
             Chr(10), vbTextCompare) + 1)
          Cells(i + k, 2) = Left(Cells(i + k, 2), _
             InStr(1, Cells(i + k, 2), _
             Chr(10), vbTextCompare) - 1)
          '-- column C
          Cells(i + k + 1, 3) = Mid(Cells(i + k, 3), _
             InStr(1, Cells(i + k, 3), _
             Chr(10), vbTextCompare) + 1)
          Cells(i + k, 3) = Left(Cells(i + k, 3), _
             InStr(1, Cells(i + k, 3), _
             Chr(10), vbTextCompare) - 1)
          '-- column D
          Cells(i + k + 1, 4) = Mid(Cells(i + k, 4), _
             InStr(1, Cells(i + k, 4), _
             Chr(10), vbTextCompare) + 1)
          Cells(i + k, 4) = Left(Cells(i + k, 4), _
             InStr(1, Cells(i + k, 4), _
             Chr(10), vbTextCompare) - 1)
          '-- column E
          Cells(i + k + 1, 5) = Mid(Cells(i + k, 5), _
             InStr(1, Cells(i + k, 5), _
             Chr(10), vbTextCompare) + 1)
          Cells(i + k, 5) = Left(Cells(i + k, 5), _
             InStr(1, Cells(i + k, 5), _
             Chr(10), vbTextCompare) - 1)
          '-- column F
          Cells(i + k + 1, 6) = Mid(Cells(i + k, 6), _
             InStr(1, Cells(i + k, 6), _
             Chr(10), vbTextCompare) + 1)
          Cells(i + k, 6) = Left(Cells(i + k, 6), _
             InStr(1, Cells(i + k, 6), _
             Chr(10), vbTextCompare) - 1)

        Next k
      End If
    Next i
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Just in case anyone else is looking for similar.