Any Easy way to Split Multiple cells in sheet into separate rows??

[andiellenb]

I've inherited an Excel file used for scheduling that has multiple timeslots in one cell - a formatting nightmare!
Is there a way to easily split these (like the text to columns) except for rows?

Thanks!

example row:

Computer Lab 1

8:00-8:50 open 9:00-9:30 open 6th Tech - 9:35-10:20 10:20-11:10 Gifted - 11:10-11:40 5th Grade 11:40-12:10 open 12:20-12:50 3rd Grade 12:50-1:50 1:50-2:25 4th Gifted 2:30-3:00 open

8:00-8:50 9:00-9:30 6th Tech - 9:35-10:20 10:20-11:10 Gifted - 11:10-11:40 5th Grade 11:40-12:10 2nd Grade 12:20-12:50 3rd Grade 12:50-1:20 open 1:55-2:25 4th Gifted 2:30-3:00 open

Gifted - s 8:00-8:40 1st Grade 8:50-9:30 6th Tech - 9:35-10:20 10:20-11:10 Gifted - 11:10-11:40 5th Grade 11:40-12:10 2nd Grade 12:20-12:50 open 12:50-1:20 1:55-2:25 4th Gifted 2:30-3:00 open

Gifted - Robles 8:00-8:40 1st Grade 8:50-9:30 6th Tech - 9:35-10:20 10:20-11:10 Gifted - 11:10-11:40 5th Grade 11:40-12:10 2nd Grade 12:20-12:50 3rd Grade 12:50-1:20 open 1:25-1:55 1:55-2:25 4th Gifted 2:30-3:00 open

Gifted - 8:00-8:40 1st Grade 8:50-9:30 6th Tech - 9:35-10:20 10:20-11:10 Gifted - 11:10-11:40 5th Grade 11:40-12:10 2nd Grade 12:20-12:50 3rd Grade 12:50-1:45 TESTING 1:55-2:25 4th Gifted 2:30-3:00 open

<tbody>
</tbody>

 

[Special-K99]

This isnt the best way and it wont copy column A down the list but you havent said anything about column A.

Sub k1()
lastrow = Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To lastrow
LastCol = Worksheets("Sheet1").Cells(i, Columns.Count).End(xlToLeft).Column
For n = 1 To LastCol
j = Worksheets("Sheet1").Cells(i, n) & Chr(10)
l = ""
m = 1
For k = 1 To Len(j)
If Mid(j, k, 1) = Chr(10) Then
    Worksheets("Sheet2").Cells(m, n) = l: l = "": m = m + 1
Else
    l = l & Mid(j, k, 1)
End If
Next k
Next n
Next i
End Sub

Number of rows to split in column A, Input on Sheet1, output on Sheet2