Combining transpose, Count and IF

[rooirokbokkie]

Hi everyone. I'm having some serious issues with a data set from hell. I managed to merge 3 separate excel files using a combination of IF's, VLOOKUP and sacrificing small animals.

But now I'm hopelessly stuck. the data set contains about 5000 students but their marks are organized in rows and not columns. I need it in columns for SPSS to like it. (so it should look like Sheet 2)

However, there are over 450 subjects and I can only use a subject for analysis if there are more than 100 students who took that subject. I need to somehow transpose the subjects and marks into a new sheet but only if the subject count exceeds 100. Essentially it needs to run down column B and D in Sheet1 and if there are more than 100 students that have taken a specific subject then it should write that subject to a new column in a new sheet and allocate the relevant marks to the relevant student number.

So for argument's sake, let's assume that only Accounting, English, Mathematics, Chemistry 171, and Calculus 158 had more than 100 counts in Sheet 1. This produces Sheet2. It can chuck the other stuff out.

I hope i made it clear what the issue is. I would appreciate some help an awful lot as I don't have time to learn VBA in a day.

[Bob Phillips]

The easy way is to just pivot it, but here is some code to do it

Public Sub BasicLoop()
Dim this As Worksheet
Dim sh As Worksheet
Dim rowLast As Long
Dim rowMatch As Long
Dim colMatch As Long
Dim i As Long


    Application.ScreenUpdating = False
    
    Set this = ActiveSheet
    Set sh = Worksheets.Add
    sh.Name = "Formatted"
    sh.Range("A1").Value = "Student"
    
    With this
    
        rowLast = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = 2 To rowLast
        
            rowMatch = 0
            On Error Resume Next
            rowMatch = Application.Match(.Cells(i, "A").Value, sh.Columns(1), 0)
            On Error GoTo 0
            If rowMatch = 0 Then
            
                rowMatch = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row + 1
                sh.Cells(rowMatch, "A").Value = .Cells(i, "A").Value
            End If
            If .Cells(i, "B").Value <> "" Then
            
                colMatch = 0
                On Error Resume Next
                colMatch = Application.Match(.Cells(i, "B").Value, sh.Rows(1), 0)
                On Error GoTo 0
                If colMatch = 0 Then
                
                    colMatch = sh.Cells(1, sh.Columns.Count).End(xlToLeft).Column + 1
                    sh.Cells(1, colMatch).Value = .Cells(i, "B").Value
                End If
                
                sh.Cells(rowMatch, colMatch).Value = .Cells(i, "C").Value
            End If
        Next i
        
        sh.Rows(1).Font.Bold = True
        sh.Columns.AutoFit
    End With
    
    Application.ScreenUpdating = True
End Sub

[rooirokbokkie]

Wow. That worked flawlessly. You sir are a saint. I'll study the macro later to day to try to learn from it. Thank you aigain.

[snb]

or

Sub M_snb()
    sp = Sheet3.Cells(1).CurrentRegion.Rows(1)
    ReDim sq(0, UBound(sp, 2))
    sn = [if(sheet1!A1:A1000="","",if(Column(A1:C1000)=1,A1:A1000,if($B1:$B1000="",offset(A1:C1000,,2),$A1:$C1000)))]
    
    With CreateObject("scripting.dictionary")
      For j = 2 To UBound(sn)
        st = .Item(sn(j, 1))
        If VarType(st) = 0 Then st = sq
        
        st(0, 0) = sn(j, 1)
        If Not IsError(Application.Match(sn(j, 2), sp, 0)) Then st(0, Application.Match(sn(j, 2), sp, 0) - 1) = sn(j, 3)
        .Item(sn(j, 1)) = st
      Next
      
      Sheet3.Cells(2, 1).Resize(.Count, UBound(sp, 2) + 1) = Application.Index(.items, 0, 0)
    End With
End Sub