Completely changing the structure of a sheet

[rooirokbokkie]

I'm currently working with a pretty messy data set and I need to consolidate the information on one sheet so I can analyse it. There are actually multiple issues but I thought I'd start with the first one. The data set is pretty big (70 000 ish rows and 20 columns) so I can't randomly cut and paste stuff.

Luckily the sheet contains a unique student number for each student. The problem is this. In sheet 1 each row represents a subject for each student. So the number of times a student appears is a function of the number of subjects he/she has and other data (like faculty) is in a new column.

Sheet 1:

Student Number	Subject	Mark	Faculty
345689	Calculus	83
345689	Physics	89
345689	Informatics	86
345689	Statistics	69
345689			Science
178907	Psychology	76
178907	Social Work	89
178907			Humanities
563333	Calculus	77
563333	Linear Algebra	66
563333	Physics	91
563333			Engineering

<tbody>
</tbody>

I need a data set where each student is represented on one row only and the columns are subjects. Ideally it should look something like sheet 2. The other problem is that there are over 300 subjects and at most a particular student will have maybe 20 of them. So there's going to be an awful lot of empty cells if I try to straight up convert the subjects found in the rows of sheet 1 to columns. I thought about splitting the data up with each faculty on a different sheet, but how can I migrate their subjects marks like that?

Sheet 2:

Student Number	Faculty	Calculus	Physics	Informatics	Statistics	Psychology	Social Work	Linear Algebra
345689	Science	83	89	86	69	-	-	-
178907	Humanities	-	-	-	-	76	89	-
563333	Engineering	77	91	-	-	-	-	66

<tbody>
</tbody>

I'd really appreciate some help. I'd be willing to take a shot at vba if it gets the job done

 

[StevenVB]

Try the codes below:




Sub Restructure()

Dim i, j, k, StudentRow, NoSubject As Integer
Dim lastRow, lastCol As Integer
Dim ws1, ws2 As String
Dim SubjectFound As Boolean

ws1 = "Sheet1"
ws2 = "Sheet2"
lastRow = Sheets(ws1).Cells(Rows.Count, 1).End(xlUp).Row
StudentRow = 1
NoSubject = 3

For i = 2 To lastRow

'For each new student number
If (Sheets(ws1).Cells(i, 1).Value <> Sheets(ws1).Cells(i - 1, 1).Value) And Sheets(ws1).Cells(i, 1).Value <> "" Then
StudentRow = StudentRow + 1
Sheets(ws2).Cells(StudentRow, 1).Value = Sheets(ws1).Cells(i, 1).Value
End If

'For each subject
Sheets(ws2).Cells(1, 3).Value = Sheets(ws1).Cells(2, 2).Value

If Sheets(ws1).Cells(i, 2).Value <> "" Then
SubjectFound = False

For j = 3 To NoSubject
If Sheets(ws1).Cells(i, 2).Value = Sheets(ws2).Cells(1, j).Value Then
SubjectFound = True
Sheets(ws2).Cells(StudentRow, j).Value = Sheets(ws1).Cells(i, 3).Value
End If
Next j

If SubjectFound = False Then
NoSubject = NoSubject + 1
Sheets(ws2).Cells(1, NoSubject).Value = Sheets(ws1).Cells(i, 2).Value
Sheets(ws2).Cells(StudentRow, NoSubject).Value = Sheets(ws1).Cells(i, 3).Value
End If

End If

'For each faculty
If Sheets(ws1).Cells(i, 4).Value <> "" Then
Sheets(ws2).Cells(StudentRow, 2).Value = Sheets(ws1).Cells(i, 4).Value
End If

Next i

End Sub

 

[rooirokbokkie]

Thanks you for taking a shot at it. I ran the code but I get a

Subscript out of range error.

This line seems to be the culprit

lastRow = Sheets(ws1).Cells(Rows.Count, 1).End(xlUp).Row

 

[StevenVB]

Probably due to your worksheet name differ from mine. Can u change your worksheet name to Sheet1 (without space )and make up a blank worksheet named Sheet2?

 

[hiker95]

rooirokbokkie,

Welcome to the MrExcel forum.

1. What version of Excel and Windows are you using?

2. Are you using a PC or a Mac?


I assume that your raw data is sorted/grouped by/in column A.


Sample raw data in worksheet Sheet1:

Excel 2007
	A	B	C	D
1	Student Number	Subject	Mark	Faculty
2	345689	Calculus	83
3	345689	Physics	89
4	345689	Informatics	86
5	345689	Statistics	69
6	345689			Science
7	178907	Psychology	76
8	178907	Social Work	89
9	178907			Humanities
10	563333	Calculus	77
11	563333	Linear Algebra	66
12	563333	Physics	91
13	563333			Engineering
14
Sheet1

After the macro in worksheet Sheet2:

Excel 2007
	A	B	C	D	E	F	G	H	I
1	Student Number	Faculty	Calculus	Physics	Informatics	Statistics	Psychology	Social Work	Linear Algebra
2	345689	Science	83	89	86	69	-	-	-
3	178907	Humanities	-	-	-	-	76	89	-
4	563333	Engineering	77	91	-	-	-	-	66
5
Sheet2

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub ReorgData()
' hiker95, 08/22/2014, ME800719
Dim w1 As Worksheet, w2 As Worksheet
Dim r As Long, lr1 As Long, lr2 As Long, rr As Long, lc2 As Long, n As Long
Dim sn As Range, su As Range
Application.ScreenUpdating = False
Set w1 = Sheets("Sheet1")
If Not Evaluate("ISREF(Sheet2!A1)") Then Worksheets.Add(After:=w1).Name = "Sheet2"
Set w2 = Sheets("Sheet2")
w2.UsedRange.Clear
With w1
  lr1 = .Cells(Rows.Count, 1).End(xlUp).Row
  .Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=w2.Columns(1), Unique:=True
  .Columns(2).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=w2.Columns(2), Unique:=True
  lr2 = w2.Cells(Rows.Count, 2).End(xlUp).Row
  w2.Range("B1:B" & lr2).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
  lr2 = w2.Cells(Rows.Count, 2).End(xlUp).Row
  w2.Range("C1").Resize(, lr2 - 1).Value = Application.Transpose(w2.Range("B2:B" & lr2).Value)
  w2.Range("B1:B" & lr2).ClearContents
  w2.Range("B1").Value = "Faculty"
  w2.UsedRange.Columns.AutoFit
  lr2 = w2.Cells(Rows.Count, 1).End(xlUp).Row
  lc2 = w2.Cells(1, Columns.Count).End(xlToLeft).Column
  With w2.Range(w2.Cells(2, 3), w2.Cells(lr2, lc2))
    .Value = "-"
    .HorizontalAlignment = xlCenter
  End With
  For r = 2 To lr1
    n = Application.CountIf(.Columns(1), .Cells(r, 1).Value)
    Set sn = w2.Columns(1).Find(.Cells(r, 1).Value, LookAt:=xlWhole)
    For rr = r To r + n - 1 Step 1
      If .Cells(rr, 2) = "" Then
        w2.Cells(sn.Row, 2) = .Cells(rr, 4).Value
      ElseIf .Cells(rr, 2) <> "" Then
        Set su = w2.Rows(1).Find(.Cells(rr, 2).Value, LookAt:=xlWhole)
        If Not su Is Nothing Then
          w2.Cells(sn.Row, su.Column).Value = .Cells(rr, 3).Value
        End If
      End If
    Next rr
    Set sn = Nothing
    Set su = Nothing
    r = r + n - 1
  Next r
End With
With w2
  .UsedRange.Columns.AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgData macro.

 

[hiker95]

rooirokbokkie,

Have you even tried my macro?

 

[rooirokbokkie]

Hi hiker95,

Sorry for taking so long to respond. The macro makes my Excel crash for some reason. I tried running it on my home pc on a different version of Excel but the exact same thing happened. I decided to try to bypass the faculty issues manually by splitting the faculties by using VLOOKUP so the data looks like this.

http://www.mrexcel.com/forum/excel-questions/801628-conditional-transposing.html

 

[mfexcel]

You may try

1) Fill in the blank in the table
Fill in the blanks – quickly | wmfexcel
Note: do not just follow the steps. As your data layout is a bit different, you would need = DOWN ARROW instead in step 5.

2) Then apply Pivot Table to get your desired layout