Split Cells that have Alt+Enter Text Into Multiple rows and fill rows accrodingly.

[pyrte]

Hi guys,

I have about 10 columns filled with data and most of the columns have data entered using Alt+Enter. This shows multiple values in one cell. I need to put these in separate rows while retaining the other values in the row.

I found a macro online but this one has a restriction to validating only one column at a time that results in multiple duplicates for every time I run the macro.


Sub CellSplitter()
Dim Temp As Variant
Dim CText As String
Dim J As Integer
Dim K As Integer
Dim L As Integer
Dim iColumn As Integer
Dim lNumCols As Long
Dim lNumRows As Long

iColumn = 5

Set wksSource = ActiveSheet
Set wksNew = Worksheets.Add

iTargetRow = 0
With wksSource
lNumCols = .Range("IV1").End(xlToLeft).Column
lNumRows = .Range("A65536").End(xlUp).Row
For J = 1 To lNumRows
CText = .Cells(J, iColumn).Value
Temp = Split(CText, Chr(10))
For K = 0 To UBound(Temp)
iTargetRow = iTargetRow + 1
For L = 1 To lNumCols
If L <> iColumn Then
wksNew.Cells(iTargetRow, L) _
= .Cells(J, L)
Else
wksNew.Cells(iTargetRow, L) _
= Temp(K)
End If
Next L
Next K
Next J
End With
End Sub



Please let me know if anyone can help me fix this or write me a new macro that will help me solve this issue. Appreciate all the help you can offer.

[mana]

???


Option Explicit

Sub test()
Dim dic As Object
Dim v
Dim ws As Worksheet
Dim i As Long, j As Long, k As Long
Dim s

v = Range("a1").CurrentRegion
Set dic = CreateObject("scripting.dictionary")
Set ws = Worksheets.Add

For j = 1 To UBound(v, 2)
For i = 1 To UBound(v, 1)
s = Split(v(i, j), Chr(10))
For k = 0 To UBound(s)
dic(dic.Count) = s(k)
Next
Next
ws.Columns(j).Range("a1").Resize(dic.Count).Value = _
WorksheetFunction.Transpose(dic.items)
dic.RemoveAll
Next

End Sub

[pyrte]

mana, Thanks for that code. But it looks like the code is pushing down the values in the particular column alone and the new value is matched against the other rows that already exist.

Here is what I'm looking for.

17091

[snb]

Why don't you upload a sample file ?

[mana]

Option Explicit

Sub test2()
Dim rr As Range, r As Range
Dim c As Range
Dim s, k As Long

Set rr = Range("a1").CurrentRegion
Set rr = Intersect(rr, rr.Offset(1))

For Each r In rr.Rows
For Each c In r.Cells
If InStr(c.Value, vbLf) > 0 Then
s = Split(c.Value, vbLf)
For k = 0 To UBound(s)
r.Copy
r.Insert xlShiftDown
c.Offset(-1).Value = s(k)
Next
r.Delete xlShiftUp
Exit For
End If
Next
Next

End Sub

[pyrte]

Mana, The macro you gave works just like the one I posted. It works only on the first column of the data set. I've attached a sample file that might help you. Thanks for helping out with this.17120

[mana]

Option Explicit

Sub test3()
Dim rr As Range, r As Range
Dim c As Range
Dim s, k As Long, n As Long
Dim IsFirst As Boolean

Set rr = Range("a1").CurrentRegion
Set rr = Intersect(rr, rr.Offset(1))

For Each r In rr.Rows
IsFirst = True
For Each c In r.Cells
If InStr(c.Value, vbLf) > 0 Then
s = Split(c.Value, vbLf)
If IsFirst Then
For k = 0 To UBound(s)
r.Copy
r.Insert xlShiftDown
c.Offset(-1).Value = s(k)
Next
IsFirst = False
Else
For k = 0 To UBound(s)
c.Offset(-k - 1).Value = s(UBound(s) - k)
Next
End If
End If
Next
If IsFirst = False Then r.Delete xlShiftUp
Next

End Sub

[SamT]

Brute force, and probably has some mistakes.


Sub VBAX_SamT()
Dim Cel As Range
Dim CelVal As Variant
Dim ValCount As Long
Dim Sht As Worksheet
Dim i As Long

Set Sht = Sheets("Sheet Whatever") '<<<<<<<<<

For Each Cel In Range(Intersect(Sht.UsedRange, Sht.Range("Columns with shift enter"))) '<<<<<<<<
If InStr(Cel, Chr(10)) = 0 Then GoTo CelNext

CelVal = Split(Cel, Chr(10))
ValCount = UBound(CelVal) - (LBound(CelVal) - 1)

For i = 1 To ValCount - 1
Cel.EntireRow.Offset(1).Insert
Next i

Cel.EntireRow.Resize(ValCount).FillDown
Cel.Value = WorksheetFunction.Transpose(CelVal)


CelNext:
Next

End Sub

[pyrte]

mana, that worked so awesome. I cannot thank you enough. Appreciate all the help here. You are a rock star.