insert appropriate number of blank spaces in cells B through H

I am having trouble trying to figure out how to insert blank cells:
I need to insert cells, in columns B through H, equal to the number of returned IDs in column B.

Please take a look at the spreadsheet I attached.

Here is the code I am using to separate the IDs in column B so that I get one ID in each A cell. When I do this it separates them great, but then I have to manually go in and insert cells down so that the rest of the rows match up with the right ID.

Sub Macro1()
Dim fromCol As String
Dim toCol As String
Dim fromRow As String
Dim toRow As String
Dim inVal As String
Dim outVal As String
Dim commaPos As Integer

' Copy from column B to column A.'
fromCol = "B"
toCol = "A"
fromRow = "1"
toRow = "1"

' Go until no more entries in column B.'
inVal = Range(fromCol + fromRow).Value
While inVal <> ""

' Go until all sub-entries used up.'
While inVal <> ""
Range(fromCol + fromRow).Select

' Extract each subentry.'
commaPos = InStr(1, inVal, ",")
While commaPos <> 0

' and write to output column.'
outVal = Left(inVal, commaPos - 1)
Range(toCol + toRow).Select
Range(toCol + toRow).Value = outVal
toRow = Mid(str(Val(toRow) + 1), 2)

' Remove that sub-entry.'
inVal = Mid(inVal, commaPos + 1)
While Left(inVal, 1) = " "
inVal = Mid(inVal, 2)
Wend
commaPos = InStr(1, inVal, ",")
Wend

' Get last sub-entry (or full entry if no commas).'
Range(toCol + toRow).Select
Range(toCol + toRow).Value = inVal
toRow = Mid(str(Val(toRow) + 1), 2)
inVal = ""
Wend

' Advance to next source row.'
fromRow = Mid(str(Val(fromRow) + 1), 2)
Range(fromCol + fromRow).Select
inVal = Range(fromCol + fromRow).Value
Wend
End Sub
sample of separate.xlsm

Any ideas?

Thanks!
Holly