LMS Macro

LMSMacro.bas

Option Explicit
Dim sourceWS As Worksheet
Dim destWS As Worksheet

Sub factoryForLMS()
    If Not doesWSExist("Analysis", ActiveWorkbook.name, False) Then buildAnalysisReport
    buildPerPerson
    Sheets("Analysis").Activate
End Sub

Sub buildPerPerson()
    Dim theWS As Worksheet
    Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        If Not LCase(ws.name) = "analysis" Then
            Set theWS = ws
            Exit For
        End If
    Next ws
        Dim r As Integer
        Dim plur As Integer: plur = lastUsedRow(theWS.name)
        For r = 7 To plur
            DoEvents: Application.StatusBar = r & " of " & plur
            With theWS
                Dim username As String: username = .Range("a" & r)
                Dim fName As String: fName = .Range("b" & r)
                Dim lname As String: lname = .Range("c" & r)
                If InStr(1, .Range("d" & r), "'") > 0 Then .Range("d" & r) = Replace(.Range("d" & r), "'", "")
                Dim theDate As String: theDate = .Range("d" & r)
                If InStr(1, .Range("e" & r), "'") > 0 Then .Range("E" & r) = Replace(.Range("e" & r), "'", "")
                Dim score As Double: score = .Range("e" & r)
            End With
            Dim personWS As String: personWS = Left(username, 28)
            If Not doesWSExist(personWS, ActiveWorkbook.name, False) Then
                createNewWS personWS, False, True
                With Sheets(personWS)
                    .Cells.VerticalAlignment = xlVAlignTop
                    ActiveWindow.DisplayGridlines = False
                    thinInnerBorder .Range("b1:b5")
                    .Cells.WrapText = True
                    standardRowTitles .Range("a1")
                    standardRowTitles .Range("a2")
                    standardRowTitles .Range("a3")
                    standardRowTitles .Range("a4")
                    standardRowTitles .Range("a5")
                    standardColumnTitles .Range("a7:b7")
                    .Range("b5").NumberFormat = "0%"
                    
                    .Columns("a").ColumnWidth = 50
                    .Columns("b").ColumnWidth = 50
                    .Rows("8").Select
                    ActiveWindow.FreezePanes = True
                    .Rows("7").AutoFilter
                    .Range("a1") = "Username"
                    .Range("b1") = username
                    .Range("a2") = "First name"
                    .Range("B2") = fName
                    .Range("a3") = "Last name"
                    .Range("b3") = lname
                    .Range("a4") = "Completion"
                    .Range("b4") = theDate
                    .Range("a5") = "Score"
                    .Range("b5") = score
                    .Range("a7") = "Question"
                    .Range("b7") = "Answered correctly?"
                    Dim i As Integer: i = 8
                    Dim c As Integer
                    For c = 7 To lastUsedCol(False, theWS.name)
                        DoEvents: Application.StatusBar = username & " | " & c
                        If theWS.Range(columnLetter(c) & "6") = "answer is correct" Then
                            .Range("a" & i) = theWS.Range(columnLetter(c) & "1").Value
                            .Range("b" & i) = theWS.Range(columnLetter(c) & r).Value
                            thinInnerBorder .Range("A" & i)
                            thinInnerBorder .Range("b" & i)
                            If .Range("b" & i) = "" Then
                                .Range("b" & i) = "No"
                                .Range("b" & i).Font.Color = xlRed
                            Else
                                .Range("b" & i).Font.Color = vbGreen
                            End If
                            i = i + 1
                        End If
                    Next c
                End With
            End If 'does ws exist
        Next r
    Application.StatusBar = False
End Sub

Sub buildAnalysisReport()
    Set sourceWS = ActiveSheet
    Range("A1").Select
    Selection.EntireRow.Insert
    Selection.EntireRow.Insert
    Selection.EntireRow.Insert
    Selection.EntireRow.Insert
    Selection.EntireRow.Insert
    Range("F1").Value = "Question"
    Range("F2").Value = "Answered  correctly"
    Range("F3").Value = "Answered incorrectly"
    Range("F4").Value = "No answer"
    
    Dim cell As Range
    For Each cell In Range("h6:" & columnLetter(Range("h6").End(xlToRight).Column) & "6")
        If cell.Value Like "*answer is correct*" Then
            cell.Offset(-5, 0).Value = cell.Offset(0, -1)
            cell.Offset(-4, 0).FormulaLocal = "=COUNTIF(" & columnLetter(cell.Column) & "7:" & columnLetter(cell.Column) & "" & lastUsedRow() & ",""Yes"")"
            cell.Offset(-3, 0).FormulaLocal = "=COUNTIF(" & columnLetter(cell.Column) & "7:" & columnLetter(cell.Column) & "" & lastUsedRow() & ",""No"")"
            cell.Offset(-2, 0).FormulaLocal = "=COUNTBLANK(" & columnLetter(cell.Column) & "7:" & columnLetter(cell.Column) & "" & lastUsedRow() & ")"
        End If
    Next cell
    Rows("1:4").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
    createNewWS "Analysis", True, False
    Set destWS = ActiveSheet
    
    Dim i As Integer
    For i = 1 To 4
        moveStuffOver i
    Next i
    
    Range("E1").Value = "Incorrect response %"
    Range("F1").Value = "Correct response %"
    Range("g1").Value = "Incorrect response ranking"
    Range("h1").Value = "Comment"
    Columns("A").ColumnWidth = 98
    Columns("B:G").ColumnWidth = 22
    Columns("h").ColumnWidth = 50
    Cells.WrapText = False
    Columns("B:G").HorizontalAlignment = xlCenter
    Columns("E:F").Style = "Percent"
    Cells.VerticalAlignment = xlTop
    standardColumnTitles Range("a1:h1")
    ActiveWindow.DisplayGridlines = False
    Range("A1:h" & lastUsedRow).AutoFilter
    ActiveWorkbook.Worksheets("Analysis").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Analysis").AutoFilter.Sort.SortFields.Add2 Key:= _
        Range("A1:A" & lastUsedRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets("Analysis").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Rows("2").Select
    ActiveWindow.FreezePanes = True
    thinInnerBorder Range("A1:h" & lastUsedRow)
    
    For i = 2 To lastUsedRow
        Range("e" & i).FormulaLocal = "=c" & i & "/(b" & i & "+c" & i & ")"
         Range("f" & i).FormulaLocal = "=b" & i & "/(b" & i & "+c" & i & ")"
    Next i
    
    ActiveWorkbook.Worksheets("Analysis").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Analysis").AutoFilter.Sort.SortFields.Add2 Key:=Range("E1:E" & lastUsedRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Analysis").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    For i = 2 To lastUsedRow
        Range("g" & i) = i - 1
    Next i
End Sub

Private Sub moveStuffOver(dataRow As Integer)
    sourceWS.Activate
    sourceWS.Range("f" & dataRow & ":" & columnLetter(Range("h6").End(xlToRight).Column) & dataRow).Select
    Selection.Copy
    destWS.Activate
    destWS.Range(columnLetter(dataRow) & "1").Activate
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End Sub