Spreadsheet Re-organization

[Guest]

I have a table of sales.

It is organized as follows:
1st column: name | second column: Item bought

This table is about 30,000 lines long. If I want to show the data in a
totally separate table in this fashion: one line per last name and all the
"items bought" going across in columns 3, 4, 5, etc (depending on how many
items they bought) what is the best way to reorganize this data in either
excel/access?

 

[Guest]

hi
am i save to assume the your data is currently layed out like this.....+

john smith Item 1
vic stone Item 1
vic stone Item 2
adam smith Item 1
adam smith Item 2
adam smith Item 3
adam smith Item 4

FSt1

 

[Guest]

That is correct. I did not mean to say "Last name". I mean to say I want to
have one name on one line, and all the items that person bought going across
on the same line.

Hope that clarifies!

 

[Guest]

hi again,
I got your code but there is a small snag with it that don't make sence.
working on it. brb

FSt1

 

[Guest]

hi agian
here it is. make a back up copy before you run this. it worked on the sample
data i asked about.
Sub spreaditout()
Dim ro As Range
Dim rt As Range
Dim rtd As Range
Dim rd As Range
'assuming headers in first row. change if needed
'change to your sheet names if needed
Set ro = Sheets("sheet1").Range("A2")
Set rt = Sheets("sheet2").Range("A2")
Range("A2").Select
Do While Not IsEmpty(ro)
Set rd = ro.Offset(1, 0)
rt.Value = ro.Value
rt.Offset(0, 1).Value = ro.Offset(0, 1).Value
Do While ro.Value = rd.Value
Set rtd = rt.Offset(1, 0)
rt.End(xlToRight).Offset(0, 1).Value = _
rd.Offset(0, 1).Value
'rd.EntireRow.Delete
Set ro = rd
Set rd = ro.Offset(1, 0)
Loop
Set ro = rd
Set rt = rt.Offset(1, 0)
Loop
End Sub

Post back if you have problems

regards
FSt1

 

[magneticpoles]

hi agian
here it is. make a back up copy before you run this. it worked on the sample
data i asked about.
Sub spreaditout()
Dim ro As Range
Dim rt As Range
Dim rtd As Range
Dim rd As Range
'assuming headers in first row. change if needed
'change to your sheet names if needed
Set ro = Sheets("sheet1").Range("A2")
Set rt = Sheets("sheet2").Range("A2")
Range("A2").Select
Do While Not IsEmpty(ro)
Set rd = ro.Offset(1, 0)
rt.Value = ro.Value
rt.Offset(0, 1).Value = ro.Offset(0, 1).Value
Do While ro.Value = rd.Value
Set rtd = rt.Offset(1, 0)
rt.End(xlToRight).Offset(0, 1).Value = _
rd.Offset(0, 1).Value
'rd.EntireRow.Delete
Set ro = rd
Set rd = ro.Offset(1, 0)
Loop
Set ro = rd
Set rt = rt.Offset(1, 0)
Loop
End Sub

Post back if you have problems

regards
FSt1





- Show quoted text -

Wouldn't a pivot table be easier?