View Single Post
  #3   Report Post  
Posted to microsoft.public.excel.programming
[email protected] stuart_bisset@yahoo.com is offline
external usenet poster
 
Posts: 8
Default multiple row data to single row

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