Splitting cell data into rows, delimited by "alt+enter"

[Adepto]

Hello all,

Can anyone help with the following scenerio?

I'm exporting data to excel. After deleting all columns except the two I need, I am left with "medication" and "Types".
The medication column contain one value per cell.
The types column has anywhere from 1 to 3 values that are on different lines (alt+enter)
It looks something like this:
[TABLE="class: grid, width: 200, align: left"]
<TBODY>[TR]
[TD]Medication[/TD]
[TD]Types[/TD]
[/TR]
[TR]
[TD]Aspirin[/TD]
[TD]1
2
3[/TD]
[/TR]
[TR]
[TD]Plavix[/TD]
[TD]4
5[/TD]
[/TR]
[TR]
[TD]Warfarin[/TD]
[TD]6
7[/TD]
[/TR]
</TBODY>[/TABLE]











I want it to look like this:
[TABLE="class: grid, width: 200, align: left"]
<TBODY>[TR]
[TD]Medication[/TD]
[TD]Types[/TD]
[/TR]
[TR]
[TD]Aspirin[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]Aspirin[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]Aspirin[/TD]
[TD]3[/TD]
[/TR]
[TR]
[TD]Plavix[/TD]
[TD]4[/TD]
[/TR]
[TR]
[TD]Plavix[/TD]
[TD]5[/TD]
[/TR]
[TR]
[TD]Warfarin[/TD]
[TD]6[/TD]
[/TR]
[TR]
[TD]Warfarin[/TD]
[TD]7[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
</TBODY>[/TABLE]
















any help would be greatly appreciated!

 

[timfritsch]

Try:

Sub test()
  Dim i As Long
  
  Cells.MergeCells = False
  
  For i = 3 To Range("B" & Rows.Count).End(xlUp).Row
    If Len(Cells(i, "A")) = 0 Then Cells(i, "A") = Cells(i - 1, "A")
  Next i
End Sub

Tim

 

[caabyyc]

This is exactly what I am doing right now but for different entry.

assume
1.your source data is in A1:B4
[TABLE="width: 104"]
<colgroup><col style="width: 63pt; mso-width-source: userset; mso-width-alt: 2986;" width="84"> <col style="width: 41pt; mso-width-source: userset; mso-width-alt: 1934;" width="54"> <tbody>[TR]
[TD="class: xl106, width: 84, bgcolor: white"]Medication[/TD]
[TD="class: xl106, width: 54, bgcolor: white"]Types[/TD]
[/TR]
[TR]
[TD="class: xl107, width: 84, bgcolor: white"]Aspirin[/TD]
[TD="class: xl106, width: 54, bgcolor: white"]1
2
3[/TD]
[/TR]
[TR]
[TD="class: xl107, width: 84, bgcolor: white"]Plavix[/TD]
[TD="class: xl106, width: 54, bgcolor: white"]4
5[/TD]
[/TR]
[TR]
[TD="class: xl107, width: 84, bgcolor: white"]Warfarin[/TD]
[TD="class: xl106, width: 54, bgcolor: white"]6
7[/TD]
[/TR]
</tbody>[/TABLE]

2. No merged cell in range
3. all data in B1:B4 is clean (QTY of "Type"=QTY of line break (alt+enter)+1)
4. all type# is one digit number or text

My solution (Not the best for sure)

1. C1=LEN(B1)-LEN(SUBSTITUTE(B1,CHAR(10),))+1, then drag it down to C4
2. Manually enter following in D1 and E1[TABLE="width: 118"]
<colgroup><col style="width: 70pt; mso-width-source: userset; mso-width-alt: 3328;" width="94"> <col style="width: 48pt;" width="64"> <tbody>[TR]
[TD="class: xl108, width: 94, bgcolor: white"]Medication[/TD]
[TD="class: xl108, width: 64, bgcolor: white"]Types[/TD]
[/TR]
</tbody>[/TABLE]
3. D2 =IF(COUNTIF($D$1:D1,D1)=INDEX(C:C,MATCH(D1,A:A,)),INDEX(A:A,MATCH(D1,A:A,)+1),D1)
4. E2 =MID(INDEX(B:B,MATCH(D2,A:A,)),COUNTIF($D$1:D2,D2)*2-1,1)
5. select D2:E2, then drag it down to bottom until you see "0" in D and "#N/A" in E.
6. D2:E8 is what you need

 

[XLfriend777]

Hi Adepto,

You might try the following to get started. It take the contents of a cell and puts each row in a cell into an array. It then prints them out in a MsgBox, but you can modify that to put the array contents where you need to. Hope this helps.

All the best,
goesr

Sub Adepto()
'Select B1 containing 1,2,3 all in the cell and run this macro
'The result is written to the MsgBox
'You can use this to then iterated through each cell and
'place the results where you want them
  Dim sText() As String
  Dim sResult As String
  sText = Split(Selection.Text, vbLf)
  Dim i As Integer
  For i = 0 To UBound(sText)
      If LCase(Left(sText(i), 4)) <> "" Then
          sResult = sResult + sText(i) & vbCrLf
      ElseIf LCase(Left(sText(i), 4)) <> "" Then
          sResult = sResult + sText(i) & vbCrLf
      End If
  Next
  MsgBox sResult
End Sub

 

[jim may]

Here's a workable macro to accomplish. Some clean up is suggested, but I got it working. I'd like to hear back from you (OP) regarding whether it was helpful to you... Jim

Sub Foo()
Range("B2").Select
Application.Calculation = xlCalculationManual
Do Until ActiveCell = ""
    ActiveCell.Value = Replace(ActiveCell.Value, vbLf, " ")
        ActiveCell.Offset(1).Select
Loop
Range("B2").Select

Do Until ActiveCell = ""
TCnt = Len(ActiveCell)
FCnt = Len(WorksheetFunction.Substitute(ActiveCell, " ", ""))
ICnt = TCnt - FCnt
ActiveCell.Offset(1).Resize(ICnt).EntireRow.Insert (ICnt)
'====================================================
MyNums = Split(ActiveCell, " ")
ActiveCell.Value = MyNums(0)
For i = LBound(MyNums) + 1 To UBound(MyNums)

ActiveCell.Offset(i).Value = MyNums(i)
Next i
'====================================================
ActiveCell.Offset(ICnt + 1).Select

Loop
ActiveCell.Offset(-1, -1).Select
Set Rng = Range(Range("A3"), Selection)
Range(Range("A3"), Selection).Select

Selection.SpecialCells(xlCellTypeBlanks).Select
With Selection
    .FormulaR1C1 = "=R[-1]C"
End With
With Rng
    .Copy
    .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End With
Application.CutCopyMode = False
Range("A1").Select
Application.Calculation = xlCalculationAutomatic
End Sub

 

[apo]

This will place the values on sheet2.

Private Sub CommandButton1_Click()
    Dim c As Long, r As Range, i As Long, d As Long, Temp() As String
    d = 0
    For Each r In Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)    ' Change this to suit your range..
        c = 2
        Temp = Split((r.Value), Chr(10))
        For i = LBound(Temp) To UBound(Temp)


            Sheets("Sheet2").Cells(r.Row, c - 1).Offset(d, 0).Value = Cells(r.Row, r.Column - 1).Value
            Sheets("Sheet2").Cells(r.Row, c).Offset(d, 0).Value = Temp(i)
            d = d + 1
        Next
        d = d - 1
    Next
    Sheets("Sheet2").Select
End Sub

<b>Sheet1</b><br /><br /><table border="1" cellspacing="0" cellpadding="0" style="font-family:Calibri,Arial; font-size:11pt; background-color:#ffffff; padding-left:2pt; padding-right:2pt; "> <colgroup><col style="font-weight:bold; width:30px; " /><col style="width:101px;" /><col style="width:93px;" /></colgroup><tr style="background-color:#cacaca; text-align:center; font-weight:bold; font-size:8pt; "><td > </td><td >A</td><td >B</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >1</td><td >Medication</td><td >Types</td></tr><tr style="height:55px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >2</td><td >Asprin</td><td style="text-align:right; ">1<br />2<br />3</td></tr><tr style="height:36px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >3</td><td >Plavix</td><td style="text-align:right; ">4<br />5</td></tr><tr style="height:36px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >4</td><td >Warfarin</td><td style="text-align:right; ">6<br />7</td></tr></table> <br />Excel tables to the web - Excel Jeanie Html 4

<b>Sheet2</b><br /><br /><table border="1" cellspacing="0" cellpadding="0" style="font-family:Calibri,Arial; font-size:11pt; background-color:#ffffff; padding-left:2pt; padding-right:2pt; "> <colgroup><col style="font-weight:bold; width:30px; " /><col style="width:110px;" /><col style="width:64px;" /></colgroup><tr style="background-color:#cacaca; text-align:center; font-weight:bold; font-size:8pt; "><td > </td><td >A</td><td >B</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >1</td><td >Medication</td><td >Types</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >2</td><td >Asprin</td><td style="text-align:right; ">1</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >3</td><td >Asprin</td><td style="text-align:right; ">2</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >4</td><td >Asprin</td><td style="text-align:right; ">3</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >5</td><td >Plavix</td><td style="text-align:right; ">4</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >6</td><td >Plavix</td><td style="text-align:right; ">5</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >7</td><td >Warfarin</td><td style="text-align:right; ">6</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >8</td><td >Warfarin</td><td style="text-align:right; ">7</td></tr></table> <br />Excel tables to the web - Excel Jeanie Html 4

 

[Adepto]

Here's a workable macro to accomplish. Some clean up is suggested, but I got it working. I'd like to hear back from you (OP) regarding whether it was helpful to you... Jim

Sub Foo()
Range("B2").Select
Application.Calculation = xlCalculationManual
Do Until ActiveCell = ""
    ActiveCell.Value = Replace(ActiveCell.Value, vbLf, " ")
        ActiveCell.Offset(1).Select
Loop
Range("B2").Select

Do Until ActiveCell = ""
TCnt = Len(ActiveCell)
FCnt = Len(WorksheetFunction.Substitute(ActiveCell, " ", ""))
ICnt = TCnt - FCnt
ActiveCell.Offset(1).Resize(ICnt).EntireRow.Insert (ICnt)
'====================================================
MyNums = Split(ActiveCell, " ")
ActiveCell.Value = MyNums(0)
For i = LBound(MyNums) + 1 To UBound(MyNums)

ActiveCell.Offset(i).Value = MyNums(i)
Next i
'====================================================
ActiveCell.Offset(ICnt + 1).Select

Loop
ActiveCell.Offset(-1, -1).Select
Set Rng = Range(Range("A3"), Selection)
Range(Range("A3"), Selection).Select

Selection.SpecialCells(xlCellTypeBlanks).Select
With Selection
    .FormulaR1C1 = "=R[-1]C"
End With
With Rng
    .Copy
    .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End With
Application.CutCopyMode = False
Range("A1").Select
Application.Calculation = xlCalculationAutomatic
End Sub

Hi Jim, this worked great for the example I set out.
I work in the medical field and this level of excel is way above my head but wihtout it, it woul take me forever to go through the data I need to analyze.

I tested it out on a second set of data, is there a way to have it only use (alt+enter) as the delimiter? currently some cells have text seperated by a space and this macro also seperates those.

Is there a way to attach the excel sheet I'm working on? I've removed all patient information already, so I'm not worried about sharing it.

 

[Adepto]

This will place the values on sheet2.

Private Sub CommandButton1_Click()
    Dim c As Long, r As Range, i As Long, d As Long, Temp() As String
    d = 0
    For Each r In Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)    ' Change this to suit your range..
        c = 2
        Temp = Split((r.Value), Chr(10))
        For i = LBound(Temp) To UBound(Temp)


            Sheets("Sheet2").Cells(r.Row, c - 1).Offset(d, 0).Value = Cells(r.Row, r.Column - 1).Value
            Sheets("Sheet2").Cells(r.Row, c).Offset(d, 0).Value = Temp(i)
            d = d + 1
        Next
        d = d - 1
    Next
    Sheets("Sheet2").Select
End Sub

Sheet1

	A	B
Medication	Types
Asprin
Plavix
Warfarin

<COLGROUP><COL style="WIDTH: 30px; FONT-WEIGHT: bold"><COL style="WIDTH: 101px"><COL style="WIDTH: 93px"></COLGROUP><TBODY>
[TD="bgcolor: #cacaca, align: center"]1[/TD]

[TD="bgcolor: #cacaca, align: center"]2[/TD]

[TD="align: right"]1
2
3[/TD]

[TD="bgcolor: #cacaca, align: center"]3[/TD]

[TD="align: right"]4
5[/TD]

[TD="bgcolor: #cacaca, align: center"]4[/TD]

[TD="align: right"]6
7[/TD]

</TBODY>

Excel tables to the web - Excel Jeanie Html 4

Sheet2

	A	B
Medication	Types
Asprin
Asprin
Asprin
Plavix
Plavix
Warfarin
Warfarin

<COLGROUP><COL style="WIDTH: 30px; FONT-WEIGHT: bold"><COL style="WIDTH: 110px"><COL style="WIDTH: 64px"></COLGROUP><TBODY>
[TD="bgcolor: #cacaca, align: center"]1[/TD]

[TD="bgcolor: #cacaca, align: center"]2[/TD]

[TD="align: right"]1[/TD]

[TD="bgcolor: #cacaca, align: center"]3[/TD]

[TD="align: right"]2[/TD]

[TD="bgcolor: #cacaca, align: center"]4[/TD]

[TD="align: right"]3[/TD]

[TD="bgcolor: #cacaca, align: center"]5[/TD]

[TD="align: right"]4[/TD]

[TD="bgcolor: #cacaca, align: center"]6[/TD]

[TD="align: right"]5[/TD]

[TD="bgcolor: #cacaca, align: center"]7[/TD]

[TD="align: right"]6[/TD]

[TD="bgcolor: #cacaca, align: center"]8[/TD]

[TD="align: right"]7[/TD]

</TBODY>

Excel tables to the web - Excel Jeanie Html 4

Hi Apo, thanks for the help also!
As I replied to Jim...I'm no where near either your level of expertise in excel. I figured out how to run the type of macro Jim posted but I'm not sure if i'm doing something wrong with the one you posted because I can't get it to work. Do I copy+paste it in the the same place? (alt+f11)?

 

[apo]

Hi..

I tested it out on a second set of data, is there a way to have it only use (alt+enter) as the delimiter?

Mine splits it on that... Chr(10)...

Do I copy+paste it in the the same place? (alt+f11)?

Yeah.. sorry about that.. in my example i linked the code to a CommandButton.. so.. either add an ActiveX CommandButton and put the code into that or.. just change..

Private Sub CommandButton1_Click()

to

Sub Whatever()

and paste it where you pasted Jims.

Alternatively.. upload your Workbook to Dropbox or mediafire (free accounts available at both) .. share the link here and i will apply it to your Workbook..

 

[dutyfree]

Hi,

I used the macro as given APO in Excel 2013 and getting an error:
--------------------------------------------------------
Run-time error '9':
Subscript out of range
--------------------------------------------------------


This is what I have as in the module...
--------------------------------------------------------
Sub Whatever()
Dim c As Long, r As Range, i As Long, d As Long, Temp() As String
d = 0
For Each r In Range("B1:B4" & Range("B" & Rows.Count).End(xlUp).Row)
c = 2
Temp = Split((r.Value), Chr(10))
For i = LBound(Temp) To UBound(Temp)
Sheets("Sheet2").Cells(r.Row, c - 1).Offset(d, 0).Value = Cells(r.Row, r.Column - 1).Value
Sheets("Sheet2").Cells(r.Row, c).Offset(d, 0).Value = Temp(i)
d = d + 1
Next
d = d - 1
Next
Sheets("Sheet2").Select
End Sub
--------------------------------------------------------

Please help !!!
Thanks