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:
[TABLE="width: 806"]
<tbody>[TR]
[TD]Computer Lab 1 [/TD]
[TD] 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
[/TD]
[TD] 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[/TD]
[TD]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[/TD]
[TD]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[/TD]
[TD]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[/TD]
[/TR]
</tbody>[/TABLE]

 

[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