multiple cell entries to become multiple Row entries?

[Crazyivan76]

Greetings all.


I'm a bit of a neophyte when it comes to coding in VB for Excel. I've seen other posts (re: Multiple entries in one cell, split to multiple rows?) but have a dilemma that is similar. I suspect that it will use a form of the macro posted in this thread
http://www.mrexcel.com/forum/excel-...ple-entries-one-cell-split-multiple-rows.html

I dont want to basically transpose multiple columns cells into a single row into multiple row cells in a single column. I've 500 row entries that will then explode at an alarming rate.


I am currently using Excel 2013

I have a row with multiple columns. The row start off and is fixed to a point because its customer data
Market MemberID LASTNAME FIRSTNAME DOB GENDER ADDRESS CITY STATE ZIP PHONE COUNTY

The last column in the row(s) is PRODUCT. Here I have my dilemma . Product can have multiple cells in the row and each row for each customer can be of an indeterminate size. The PRODUCT colum
Short Example

CUSTOMER INFO ROWS ---- PRODUCT
Row1 John's info blahblahblah Cats Dogs Birds Pigs Cars (each entry after product is a seperate column/cell)
Row2 Jane's info blahblahblah Tickets Barn Shotgun

Market

MEMBER ID

LAST NAME

FIRST NAME

DOB

GENDER

ADDRESS 1

ADDRESS 2

CITY

STATE

ZIP

PHONE

COUNTY

PRODUCT

North

1234

John

Doe

1/1/1970

M

123 nowhere

dallas

texas

21312

12313

12132

Apples and candy

orange

cars and squirrels

baseballs

South

3214

Jane

Smith

2/5/1971

f

321 somewhere

San antonio

texas

31215

12333

12333

Cats

dogs

pigs

horses

birds

hammers

<tbody>
</tbody>

I would like to turn this into something like this

WHAT I'D LIKE IT TO BECOME

North

1234

John

Doe

1/1/1970

M

123 nowhere

dallas

texas

21312

12313

12132

Apples and candy

North

1234

John

Doe

1/1/1970

M

123 nowhere

dallas

texas

21312

12313

12132

orange

North

1234

John

Doe

1/1/1970

M

123 nowhere

dallas

texas

21312

12313

12132

cars and squirrels

North

1234

John

Doe

1/1/1970

M

123 nowhere

dallas

texas

21312

12313

12132

baseballs

South

3214

Jane

Smith

2/5/1971

f

321 somewhere

San antonio

texas

31215

12333

12333

Cats

South

3214

Jane

Smith

2/5/1971

f

321 somewhere

San antonio

texas

31215

12333

12333

dogs

South

3214

Jane

Smith

2/5/1971

f

321 somewhere

San antonio

texas

31215

12333

12333

pigs

South

3214

Jane

Smith

2/5/1971

f

321 somewhere

San antonio

texas

31215

12333

12333

horses

South

3214

Jane

Smith

2/5/1971

f

321 somewhere

San antonio

texas

31215

12333

12333

birds

South

3214

Jane

Smith

2/5/1971

f

321 somewhere

San antonio

texas

31215

12333

12333

hammers

<tbody>
</tbody>

As to how this can be achieved, I do not know. I'm half tempted to just slog through it (well, I am) and transpose the data by hand then autofill until I start the next entry, but I know there's got to be a better way to do this. Any assistance would be greatly appreciated.

 

[JoeMo]

Assumes your header row is row 1 and first header is in A1 - adjust to suit:

Sub DataRearrange()
Dim lR As Long, lC As Long, i As Long, Ct As Long, vA() As Variant
lR = Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For i = Range("A1:A" & lR).Rows.Count To 2 Step -1
    lC = Cells(i, Columns.Count).End(xlToLeft).Column
    Ct = WorksheetFunction.CountA(Range(Cells(i, "N"), Cells(i, lC)))
    If Ct > 1 Then
        Cells(i, "A").Offset(1, 0).Resize(Ct - 1, 1).EntireRow.Insert
        Range("A" & i, "M" & i + Ct - 1).FillDown
        ReDim vA(1 To Ct - 1)
        vA = Range(Cells(i, "O"), Cells(i, lC)).Value
        Range(Cells(i, "O"), Cells(i, lC)).ClearContents
        Cells(i + 1, "N").Resize(Ct - 1, 1).Value = WorksheetFunction.Transpose(vA)
    End If
Next i
Columns("N").AutoFit
Application.ScreenUpdating = True
End Sub

 

[Crazyivan76]

I appreacite the help JoeMo. I attempted to run this and ended up with some inconsistancies. Upon looking, I had to adjust for difference in rows. The example i gave was a truncated version of the DB I am working in. My actual DB has demographic information from A to S and T is the start of the Product column/cells. I changed the strings then to contain the following changes

N became T O became U M became S

And the new VB/Macro/Script/thing became

Sub DataRearrange()
Dim lR As Long, lC As Long, i As Long, Ct As Long, vA() As Variant
lR = Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For i = Range("A1:A" & lR).Rows.Count To 2 Step -1
lC = Cells(i, Columns.Count).End(xlToLeft).Column
Ct = WorksheetFunction.CountA(Range(Cells(i, "T"), Cells(i, lC)))
If Ct > 1 Then
Cells(i, "A").Offset(1, 0).Resize(Ct - 1, 1).EntireRow.Insert
Range("A" & i, "T" & i + Ct - 1).FillDown
ReDim vA(1 To Ct - 1)
vA = Range(Cells(i, "S"), Cells(i, lC)).Value
Range(Cells(i, "U"), Cells(i, lC)).ClearContents
Cells(i + 1, "T").Resize(Ct - 1, 1).Value = WorksheetFunction.Transpose(vA)
End If
Next i
Columns("T").AutoFit
Application.ScreenUpdating = True
End Sub


You, good sir, just saved me 5 hours of grunt copy n paste work that I had resigned myself to toiling away at over the weekend. If you lived in the Tampa FL area, I'd be buying you a beer right now.

Edit: There's some fragmentation in the end result, but honestly, I would rather clean up 500 random entries than create 170k rows of data. Thanks again

 

[JoeMo]

I appreacite the help JoeMo. I attempted to run this and ended up with some inconsistancies. Upon looking, I had to adjust for difference in rows. The example i gave was a truncated version of the DB I am working in. My actual DB has demographic information from A to S and T is the start of the Product column/cells. I changed the strings then to contain the following changes

N became T O became U M became S

And the new VB/Macro/Script/thing became

Sub DataRearrange()
Dim lR As Long, lC As Long, i As Long, Ct As Long, vA() As Variant
lR = Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For i = Range("A1:A" & lR).Rows.Count To 2 Step -1
lC = Cells(i, Columns.Count).End(xlToLeft).Column
Ct = WorksheetFunction.CountA(Range(Cells(i, "T"), Cells(i, lC)))
If Ct > 1 Then
Cells(i, "A").Offset(1, 0).Resize(Ct - 1, 1).EntireRow.Insert
Range("A" & i, "T" & i + Ct - 1).FillDown
ReDim vA(1 To Ct - 1)
vA = Range(Cells(i, "S"), Cells(i, lC)).Value
Range(Cells(i, "U"), Cells(i, lC)).ClearContents
Cells(i + 1, "T").Resize(Ct - 1, 1).Value = WorksheetFunction.Transpose(vA)
End If
Next i
Columns("T").AutoFit
Application.ScreenUpdating = True
End Sub


You, good sir, just saved me 5 hours of grunt copy n paste work that I had resigned myself to toiling away at over the weekend. If you lived in the Tampa FL area, I'd be buying you a beer right now.

Edit: There's some fragmentation in the end result, but honestly, I would rather clean up 500 random entries than create 170k rows of data. Thanks again

You are welcome - thanks for the reply.