multiple row data to single row

[nigelc]

I'm not a vb programmer....

I've got a spreadsheet with student data (@1000 students) in it in th
form

refno name classcode
100 j smith 05nasabc
100 j smith 05na2bde
100 j smith 05natccc

Some students may have only 2 classes (and therefore two rows) whicls
others may have as many as seven (and 7 rows)

and I want to manipulate it so that there's only one line/student
viz:

100 j smith 05nasabc 05na2bde 05natccc

where the classcodes are in seperate columns.

All I've got so far is a macro that runs thro the sheet inserting a
empty row inbetween students, to delineate them.

Any help, anyone, pleeeese?

I've been tryin to solve this on and off all week, but my deadline i
Monday....

Cheers 'n' Beers

Nigel Crompton
Systems Manager
Bolton Sixth Form College
U

 

[Executor]

Hi nigelc

Try this:

Sub OneLinePerStudent()
Do
Do While ActiveCell.Value = ActiveCell.Offset(1; 0).Value
ActiveCell.End(xlToRight).Offset(0; 1).Value =
ActiveCell.Offset(1; 2).Value
ActiveCell.Offset(1; 0).EntireRow.Delete
Loop
ActiveCell.Offset(1; 0).Select
Loop Until IsEmpty(ActiveCell)
ActiveCell.Offset(-1; 0).End(xlUp).Select
End Sub


Hoop this helps

Executor

 

[stuart_bisset]

You should find that the following code works:

I have assumed that
(a) refno is column A
(b) name is column B
(c) Class is column C
(d) list of pupils starts in row 2

Option Explicit
Option Base 1


Sub ReWriteRecords()
Dim wks As Worksheet
Dim wkb As Workbook
Dim NewWks As Worksheet
Dim xloop, yloop As Long
Dim MyData() As Variant
Dim DataNumber As Long
Dim MaxClasses As Long
Dim NumClasses As Long

Application.ScreenUpdating = False

'sets up the new worksheet

Set wks = ActiveSheet
Set NewWks = Worksheets.Add
DataNumber = 1
MaxClasses = 1

NewWks.Select

Cells(1, 1).Value = "RefNo"
Cells(1, 2).Value = "Name"

' adds the data to the array
wks.Select

ReDim Preserve MyData(999, MaxClasses + 2)

For xloop = 1 To 999 'change 999 to your number of records
If Cells(xloop + 1, 1) = "" Then GoTo Stage2
If MyData(DataNumber, 1) <> Cells(xloop + 1, 1).Value Then
NumClasses = 1
DataNumber = DataNumber + 1
ReDim Preserve MyData(999, MaxClasses + 2) 'change 999
again
MyData(DataNumber, 1) = Cells(xloop + 1, 1).Value
MyData(DataNumber, 2) = Cells(xloop + 1, 2).Value
MyData(DataNumber, 3) = Cells(xloop + 1, 3).Value
Else
NumClasses = NumClasses + 1
If NumClasses > MaxClasses Then
MaxClasses = NumClasses
End If
ReDim Preserve MyData(999, MaxClasses + 2) ' change 999
again
MyData(DataNumber, NumClasses + 2) = Cells(xloop + 1,
3).Value
End If

Next xloop

Stage2:
' writes the data to the new sheet
NewWks.Select

For xloop = 1 To 999 ' change 999 again
For yloop = 1 To (MaxClasses + 2)
Cells(xloop + 1, yloop) = MyData(xloop, yloop)
Next yloop
Next xloop

Application.ScreenUpdating = True

End Sub


Hope this helps

 

[Stefi]

Hi Nigel,

Perhaps this is not a fully tested macro, but it run for me with a small
example:

Sub Oneline()
Range("A1").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Worksheets("Sheet2").Cells(1, 1).Value = Cells(1, 1).Value 'ref
Worksheets("Sheet2").Cells(1, 2).Value = Cells(1, 2).Value 'name
Worksheets("Sheet2").Cells(1, 3).Value = Cells(1, 3).Value 'name
r = 2
u = 1
c = 2
prevref = Cells(r, 1).Value
Do While Cells(r, 1).Value <> Empty
u = u + 1
c = 2
prevref = Cells(r, 1).Value
Worksheets("Sheet2").Cells(u, 1).Value = Cells(r, 1).Value 'ref
Worksheets("Sheet2").Cells(u, 2).Value = Cells(r, 2).Value 'name
Do
c = c + 1
prevref = Cells(r, 1).Value
Worksheets("Sheet2").Cells(u, c).Value = Cells(r, 3).Value
'classcode
r = r + 1
Loop While Cells(r, 1).Value = prevref
Loop
End Sub

Regards,
Stefi

 

[nigelc]

Thanks for two very prompt & helpful responses.
I've implemented Stuart's suggestion, as I could sorta figure out wha
was going on and make allowances for other 8 cols of data that I lef
out of the original request on the grounds of clarity .....

Cheers 'n' Beers! :