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
|