Sub SplitCells()
Dim LastR As Long
Dim DestR As Long
Dim arr As Variant
Dim Counter As Long
Dim Counter2 As Long
LastR = Cells(Rows.Count, 1).End(xlUp).Row
For Counter = 1 To LastR
If Cells(Counter, 1) <> "" Then
arr = Split(Cells(Counter, 1), Chr(10))
For Counter2 = 0 To UBound(arr)
DestR = DestR + 1
Cells(DestR, 2) = arr(Counter2)
Next
End If
Next
MsgBox "Done"
End Sub
|