Text to Rows and then Insert Blank Rows

[conorfinnegan]

I have a set of data - about 500 rows worth. Data in Colums A:C
contain the single values that I don't need to put into columns. The
data in Column D, though, is ";" delimited and I need to put that in
individual rows. I have a macro that will parse the data, but I need
to have it insert the number of blank rows down so that the other data
below it doesn't get out of line. An example data set is below

Detroit Cars Compact New;clean;5
years;special

Chicago Vans Full Old;dirty;
55k miles, not special;boring;needs repair

So I would like to have the macro make the the above look like the
below:

Detroit Cars Compact New
Detroit Cars Compact Clean
Detroit Cars Compact 5 years
Detroit Cars Compact special
Chicago Vans Full Old
Chicago Vans Full Dirty


I just need the rows inserted down for as many data points there are
in column D. I can make Columns A through C repeat their values.
Please let me know how to proceed.

I would prefere a formula or VBA. Text to columns and transpose is
not the desired solution.

Thanks in advance.

Conor

 

[Joel]

Sub seperate()

RowCount = 1
Do While Range("A" & RowCount) <> ""
Data = Range("D" & RowCount)
Do While InStr(Data, ";") > 0
FirstStr = Trim(Left(Data, InStr(Data, ";") - 1))
Data = Trim(Mid(Data, InStr(Data, ";") + 1))
Range("D" & RowCount) = FirstStr
Rows(RowCount + 1).Insert
Range("A" & RowCount & ":C" & RowCount).Copy _
Destination:=Range("A" & (RowCount + 1))
RowCount = RowCount + 1
Range("D" & RowCount) = Data
Loop
RowCount = RowCount + 1
Loop
End Sub