Traspose columns into rows, copying data from the original row in the new ones

[alvaro_v_b]

Hello Everybody!

I have a difficult task ahead and I am not sure if what I want to do is possible to be done in an authomatic way.
I have a data base with several fields/columns: A, B, C, D. In the last one (D), each field contains several words separated by a delimiter.
What I want is, for each row to generate as many rows as delimited words in column D, filling columns A, B and C with the same content of the original row.
For instance, I want to automaticly transform something like this:

ShapeKey <tbody> </tbody>	Class <tbody> </tbody>	Subclass <tbody> </tbody>	Products <tbody> </tbody>
1104 <tbody> </tbody>	12	13	Parade floats;Motor cars;Mobile laboratories;Motor graders ;Trucks for liquid manure <tbody> </tbody>
65	12	02	Trolleys;Wheel carriers ;Dollies <tbody> </tbody>

<tbody>
</tbody>

Into something like this:

ShapeKey	Class	Subclass	Products
1104	12	13	Parade floats
1104	12	13	Motor cars
1104	12	13	Mobile laboratories
1104	12	13	Motor graders
1104	12	13	Trucks for liquid manure
65	12	02	Trolleys
65	12	02	Wheel carriers
65	12	02	Dollies

<tbody>
</tbody>

(In the real case I have many more rows)
Does anybody know if this is possible in Excel?

THANK YOU SO MUCH IN ADVANCE FOR YOUR HELP!!

Alvaro

 

[mumps]

Re: Traspose columns intro rows, copying data from the original row in the new ones

This macro will place you new data in Shet2. Change the sheet names in the macro to suit your needs.

Sub SplitCells()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim Product As Range
    Dim prodArray As Variant
    Dim i As Long
    Sheets("Sheet1").Rows(1).Copy Sheets("Sheet2").Cells(1, 1)
    For Each Product In Sheets("Sheet1").Range("D2:D" & LastRow)
        prodArray = Split(Product, ";")
        For i = LBound(prodArray) To UBound(prodArray)
            Sheets("Sheet1").Range("A" & Product.Row & ":C" & Product.Row).Copy Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            Sheets("Sheet2").Cells(Rows.Count, "D").End(xlUp).Offset(1, 0) = prodArray(i)
        Next i
    Next Product
    Application.ScreenUpdating = True
End Sub

 

[alvaro_v_b]

Re: Traspose columns intro rows, copying data from the original row in the new ones

Wow mumps, this looks great!!
I have just tried it and it works perfectly, CONGRATULATIONS AND THANK YOU SO MUCH!

 

[mumps]

Re: Traspose columns intro rows, copying data from the original row in the new ones

You are very welcome.