Coding Help

J

Jcraig713

Hello All. I have a data file with the following data in rows & columns that
comes out of my system like this:

A B C D E F H
I
Stu# Advisor Lname Fname Grade Mbrship Term Mark
1000 Name Smith Jim 11 Math 001 Sem1
A
1000 Name Smith Jim 11 Math 002 Sem2
B+
1001 Name Doe John 10 Science 003 Progess2 C-
1001 Name Doe John 10 Science 003 Progress3 B

I need the data to be in one record instead of in multiple rows like this:

A B C D E F H
I J K
Stu# Advisor Lname Fname Grade Mbrship Prg2 Prg3 Sem1 Sem2
1000 Name Smith Jim 11 Math
A B+
1001 Name Doe John 10 Science C- B

And so forth. The terms can include the following but may not always be in
my data source based on the time of school year the report is being run. So
the columns H and > may be more or less each time the report is run.

I tried in my futile attempt to create the code to do this using visual
basic. Can someone help me figure what is wrong with this code? Thanks in
advance for your time:

Sub FormatList()

Dim CurWks As Worksheet
Dim NewWks As Worksheet
Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long
Dim oRow As Long
Dim res As Variant

Set CurWks = Worksheets("Sheet1")
Set NewWks = Worksheets.Add

With CurWks
FirstRow = 2
LastRow = .Cells(.Rows.Count, "H").End(xlUp).Row

'sort original range by Id, name, period
With .Range("a1:h" & LastRow)
.Sort Key1:=.Columns(1), Order1:=xlAscending, _
Key2:=.Columns(3), Order2:=xlAscending, _
Header:=xlYes
End With

'Get a list of unique class students
.Range("a1:a" & LastRow).AdvancedFilter _
action:=xlFilterCopy, unique:=True,
copytorange:=NewWks.Range("A1")
End With

With NewWks
With .Range("a:a")
.Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlYes
End With

.Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).Copy
.Range("e1").PasteSpecial Transpose:=True
.Range("a:c").Clear
End With

With CurWks
oRow = 1
For iRow = FirstRow To LastRow
If .Cells(iRow, "a").Value <> .Cells(iRow - 1, "a").Value Then

oRow = oRow + 1
NewWks.Cells(oRow, "C").Value = .Cells(iRow, "C").Value
NewWks.Cells(oRow, "D").Value = .Cells(iRow, "D").Value
NewWks.Cells(oRow, "E").Value = .Cells(iRow, "E").Value
NewWks.Cells(oRow, "H").Value = .Cells(iRow, "A").Value
Else

End If
res = Application.Match(.Cells(iRow, "h").Value,
NewWks.Rows(1), 0)
If IsError(res) Then

MsgBox "Error with row: " & iRow
Else

NewWks.Cells(oRow, res).Value = .Cells(iRow, "i").Value
End If
Next iRow
End With

NewWks.UsedRange.Columns.AutoFit

End Sub
 
J

joel

Try these changes. I like using the FIND in VBA rather than using the
worksheet MATCH.

Sub FormatList()

Dim CurWks As Worksheet
Dim NewWks As Worksheet
Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long
Dim oRow As Long
Dim res As Variant

Set CurWks = Worksheets("Sheet1")
Set NewWks = Worksheets.Add

With CurWks
FirstRow = 2
LastRow = .Cells(.Rows.Count, "H").End(xlUp).Row

'sort original range by Id, name, period
With .Range("a1:h" & LastRow)
.Sort Key1:=.Columns(1), Order1:=xlAscending, _
Key2:=.Columns(3), Order2:=xlAscending, _
Header:=xlYes
End With

'Get a list of unique class students
'change to column H
.Range("H1:H" & LastRow).AdvancedFilter _
action:=xlFilterCopy, unique:=True, _
copytorange:=NewWks.Range("A1")
End With

With NewWks
With .Range("a:a")
.Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlYes
End With
.Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).Copy
'changed to column F
.Range("F1").PasteSpecial Transpose:=True
.Range("a:c").Clear
End With

With CurWks
oRow = 1
For iRow = FirstRow To LastRow
If .Cells(iRow, "a").Value <> .Cells(iRow - 1, "a").Value Then

oRow = oRow + 1
'fixed column letters
NewWks.Cells(oRow, "A").Value = .Cells(iRow, "A").Value
NewWks.Cells(oRow, "B").Value = .Cells(iRow, "B").Value
NewWks.Cells(oRow, "C").Value = .Cells(iRow, "C").Value
NewWks.Cells(oRow, "D").Value = .Cells(iRow, "D").Value
NewWks.Cells(oRow, "E").Value = .Cells(iRow, "E").Value
Else

End If
'added new line
class = .Cells(iRow, "H").Value
'change to find instead of match
Set c = Rows(1).Find(what:=class, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then

MsgBox "Error with row: " & iRow
Else

NewWks.Cells(oRow, c.Column).Value = .Cells(iRow, "i").Value
End If
Next iRow
End With

NewWks.UsedRange.Columns.AutoFit

End Sub
 
J

Jcraig713

Hi Joel. It has taken me a bit to respond... I have be required to make
some changes to my data source file so what I sent you is no longer working.
The following now applies; do have any ideas on the new requirements? I have
tried to amend the code to get what I want but cannot get it right....

The new source data is as follows:

A B C D E F G
H I J
suniq advisor lnam fnam grade membership Crs# Crstitle
term mark
7588 Paid Rober James 20 Engineering 35005 Fabrication
P1 C
7588 Paid Rober James 20 Engineering 35005 Fabrication
P2 B
7588 Paid Rober James 20 Engineering 35005 Fabrication
P3 B
7588 Paid Rober James 20 Engineering 35005 Fabrication
Q1H B
7588 Paid Rober James 20 Engineering 35005 Fabrication
Q2H C
7588 Paid Rober James 20 Engineering 35005 Fabrication
Q3H E
7588 Paid Rober James 20 Engineering 35005 Fabrication
S1H C
1338 SLyon Carr Carl 12 BioTech 30003 Animal
Sys P2 A-
1338 SLyon Carr Carl 12 BioTech 30003 Animal
Sys P3 C
1338 SLyon Carr Carl 12 BioTech 30003 Animal
Sys Q1H B-
1338 SLyon Carr Carl 12 BioTech 30003 Animal
Sys Q2H B
1338 SLyon Carr Carl 12 BioTech 30003 Animal
Sys Q3H B+
1338 SLyon Carr Carl 12 BioTech 30003 Animal
Sys S1H B-
1338 SLyon Carr Carl 12 BioTech 30003 English
12 P1 A
1338 SLyon Carr Carl 12 BioTech 30003 English
12 P2 A-
1338 SLyon Carr Carl 12 BioTech 30003 English
12 P3 C
1338 SLyon Carr Carl 12 BioTech 30003 English
12 Q1H A
1338 SLyon Carr Carl 12 BioTech 30003 English
12 Q2H B
1338 SLyon Carr Carl 12 BioTech 30003 English
12 Q3H B-
1338 SLyon Carr Carl 12 BioTech 30003 English
12 S1H B+

I want the output to remain on 1 record line regardless of how many courses
are marked. The terms may also vary depending on what student is reported.
I would like to output on the new sheet to show:

For the student with one or many course numbers, columns A - H remain as
source data shows from left to right. Then depending on what terms a student
has marked, the folumns will continue: P1 P2 P3 P4 Q1H -Q4H to S1H etc.

I am not sure how to handle the student that has more than one course graded
though. Do you have any ideas. I just need all data for a student to be on
one record. Please please advise! :eek:)
 
J

joel

Not usre if this is what you want. Because there are teacher who are
teaching more than one class you need a seperate line for each class. I
assumed the term is what you want on the top row, not the class.

Sub FormatList()

Dim CurWks As Worksheet
Dim NewWks As Worksheet
Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long
Dim oRow As Long
Dim res As Variant
Dim NewRow As Boolean

Set CurWks = Worksheets("Sheet1")
Set NewWks = Worksheets.Add

With CurWks
FirstRow = 2
LastRow = .Cells(.Rows.Count, "H").End(xlUp).Row

'sort original range by Id, name, period
With .Range("a1:h" & LastRow)
.Sort Key1:=.Range("A1"), Order1:=xlAscending, _
Key2:=.Range("H1"), Order2:=xlAscending, _
Header:=xlYes
End With

'Get a list of unique terms
'change to column I
.Range("I1:I" & LastRow).AdvancedFilter _
action:=xlFilterCopy, unique:=True, _
copytorange:=NewWks.Range("A1")
End With

With NewWks
With .Range("a:a")
.Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlYes
End With
.Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).Copy
'changed to column F
.Range("I1").PasteSpecial Transpose:=True
.Columns("a").Clear
End With

With CurWks
oRow = 1
NewRow = True
For iRow = FirstRow To LastRow
If NewRow = True Then
oRow = oRow + 1
'fixed column letters
NewWks.Cells(oRow, "A").Value = .Cells(iRow, "A").Value
NewWks.Cells(oRow, "B").Value = .Cells(iRow, "B").Value
NewWks.Cells(oRow, "C").Value = .Cells(iRow, "C").Value
NewWks.Cells(oRow, "D").Value = .Cells(iRow, "D").Value
NewWks.Cells(oRow, "E").Value = .Cells(iRow, "E").Value
NewWks.Cells(oRow, "G").Value = .Cells(iRow, "G").Value
NewWks.Cells(oRow, "H").Value = .Cells(iRow, "H").Value
End If
'added new line
Term = .Cells(iRow, "I").Value
'change to find instead of match
Set c = Rows(1).Find(what:=Term, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then

MsgBox "Error with row: " & iRow
Else

NewWks.Cells(oRow, c.Column).Value = .Cells(iRow, "j").Value
End If
If .Cells(iRow, "a").Value <> .Cells(iRow + 1, "a").Value Or _
.Cells(iRow, "H").Value <> .Cells(iRow + 1, "H").Value Then
NewRow = True
Else
NewRow = False
End If
Next iRow
End With

NewWks.UsedRange.Columns.AutoFit

End Sub
 
J

Jcraig713

I am fine with having two seperate records.. I think you assumed that
correctly. I have a question though. See below:

This is the raw data as it appears from my database. This is in sheet 1
before I run my code:

suniq advisor lname fname grade membership course title term mrk
6323 Farming Lince Van 12 BioTech 30003 Animal Sys P2 A-
6323 Farming Lince Van 12 BioTech 30003 Animal Sys P3 A
6323 Farming Lince Van 12 BioTech 30003 Animal Sys Q1H B-
6323 Farming Lince Van 12 BioTech 30003 Animal Sys Q2H A
6323 Farming Lince Van 12 BioTech 30003 Animal Sys Q3H A
9792 Hur Val Lock Cody 11 BioTech 30004 Plant Sys P2 A+
9792 Hur Val Lock Cody 11 BioTech 30004 Plant Sys P3 F
9792 Hur Val Lock Cody 11 BioTech 30004 Plant Sys Q1H B
9792 Hur Val Lock Cody 11 BioTech 30004 Plant Sys
Q2H C+
9792 Hur Val Lock Cody 11 BioTech 30004 Plant Sys Q3H B
9792 Hur Val Lock Cody 11 BioTech 30004 Plant Sys
S1H C+
9792 Hur Val Lock Cody 11 BioTech 31004 Netwk Ad P1 B-
9792 Hur Val Lock Cody 11 BioTech 50480 BiocheTec P2 A
9792 Hur Val Lock Cody 11 BioTech 50480 BiocheTec P3 A
9792 Hur Val Lock Cody 11 BioTech 50480 BiocheTec Q1H A
9792 Hur Val Lock Cody 11 BioTech 50480 BiocheTec Q2H A
9792 Hur Val Lock Cody 11 BioTech 50480 BiocheTec Q3H A
9792 Hur Val Lock Cody 11 BioTech 50480 BiocheTec S1H A

Still in sheet 1, after I run the code, the source data now looks like this:

suniq advisor lname fname grade membership course title
term mark
6323 Farming Lince Van 12 BioTech 30003 Animal Sys
P2 A-
6323 Farming Lince Van 12 BioTech 30003 Animal Sys
Q1H B-
6323 Farming Lince Van 12 BioTech 30003 Animal Sys
Q2H A
6323 Farming Lince Van 12 BioTech 30003 Animal Sys
P3 A
6323 Farming Lince Van 12 BioTech 30003 Animal Sys
Q3H A
9792 Hur Val Lock Cody 11 BioTech 50480 BiocheTec
P2 A+
9792 Hur Val Lock Cody 11 BioTech 50480 BiocheTec
Q1H B
9792 Hur Val Lock Cody 11 BioTech 50480 BiocheTec
Q2H C+
9792 Hur Val Lock Cody 11 BioTech 50480 BiocheTec
S1H C+
9792 Hur Val Lock Cody 11 BioTech 50480 BiocheTec
P3 F
9792 Hur Val Lock Cody 11 BioTech 50480 BiocheTec
Q3H B
9792 Hur Val Lock Cody 11 BioTech 31004 Netwk Ad
P1 B-
9792 Hur Val Lock Cody 11 BioTech 30004 Plant Sys
P2 A
9792 Hur Val Lock Cody 11 BioTech 30004 Plant Sys
Q1H A
9792 Hur Val Lock Cody 11 BioTech 30004 Plant Sys
Q2H A
9792 Hur Val Lock Cody 11 BioTech 30004 Plant Sys
S1H A
9792 Hur Val Lock Cody 11 BioTech 30004 Plant Sys
P3 A
9792 Hur Val Lock Cody 11 BioTech 30004 Plant Sys
Q3H A

The output on the new sheet looks as though it is reading off the
reformatted sheet 1.... See the output below:


P1 P2 P3 Q1H Q2H Q3H S1H
6323 Farming Lince Van 12 30003 Animal Sys A- A B- A
A
9792 Hur Val Lock Cody 11 50480 BiocheTec A+ F B
C+ B C+
9792 Hur Val Lock Cody 11 31004 Netwk Ad B-
9792 Hur Val Lock Cody 11 30004 Plant Sys A A A A
A A

Of course the output is showing the incorrect grades for the classes. I
tried to look at the code to see the adjusting of the original sheet data.
Can you see anything... any suggestions?
 
J

joel

The probel is real simple. it was sorting the grades with the rest of the data

from
With .Range("a1:h" & LastRow)
to
With .Range("a1:j" & LastRow)
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Insert rows by group and copy value 2
Subtotal multiple columns and ... 0
VBA Coding Help for Beginner 0
Loopng through specific worksheets 4
Insert Row based on count and copy range to inserted rows 2
Macro Help 4
Macro Question 8
copy row based on color 1

Top