Posts by LeastAction

Public Function STDEVSIF(rngEvaluate As Range, _
    strCondition As String, _
    Optional rngValues As Range = Nothing) As Variant
    Dim varValue            As Variant
    Dim bolValueSet         As Boolean
    Dim intRow              As Integer
    Dim intCol              As Integer
    Dim dblAvg              As Double
    Dim lngCnt              As Long
     
    If (rngValues Is Nothing) Then Set rngValues = rngEvaluate
    bolValueSet = False
    If Not RangesOK(rngEvaluate, rngValues) Then
         'Return an error value
        varValue = "Error in range selection"
    Else
         'If the ranges are not identically sized can not get this far!
        dblAvg = Application.WorksheetFunction.AverageIf(rngEvaluate, strCondition, rngValues)
        lngCnt = Application.WorksheetFunction.CountIf(rngEvaluate, strCondition)
        For intRow = 1 To rngEvaluate.Rows.Count
            For intCol = 1 To rngEvaluate.Columns.Count
                If Application.CountIf(rngEvaluate(intRow, intCol), strCondition) = 1 Then
                    varValue = varValue + (rngValues(intRow, intCol) - dblAvg) ^ 2
                End If
            Next intCol
        Next intRow
        varValue = Sqr(varValue / (lngCnt - 1))
    End If
    STDEVSIF = varValue
End Function
Public Function STDEVPIF(rngEvaluate As Range, _
    strCondition As String, _
    Optional rngValues As Range = Nothing) As Variant
    Dim varValue            As Variant
    Dim bolValueSet         As Boolean
    Dim intRow              As Integer
    Dim intCol              As Integer
    Dim dblAvg              As Double
    Dim lngCnt              As Long
     
    If (rngValues Is Nothing) Then Set rngValues = rngEvaluate
    bolValueSet = False
    If Not RangesOK(rngEvaluate, rngValues) Then
         'Return an error value
        varValue = "Error in range selection"
    Else
         'If the ranges are not identically sized can not get this far!
        dblAvg = Application.WorksheetFunction.AverageIf(rngEvaluate, strCondition, rngValues)
        lngCnt = Application.WorksheetFunction.CountIf(rngEvaluate, strCondition)
        For intRow = 1 To rngEvaluate.Rows.Count
            For intCol = 1 To rngEvaluate.Columns.Count
                If Application.CountIf(rngEvaluate(intRow, intCol), strCondition) = 1 Then
                    varValue = varValue + (rngValues(intRow, intCol) - dblAvg) ^ 2
                End If
            Next intCol
        Next intRow
        varValue = Sqr(varValue / lngCnt)
    End If
    STDEVPIF = varValue
End Function

Sub Create_NameBooks()




    Dim sFilePath As String
    
    Dim oGradeSheet As Worksheet
    Dim oNameSheet As Worksheet
    Dim oWB As Workbook
    
    Dim oWS As Worksheet
    
    Dim oCell As Range
    Dim sName As String
    
    sFilePath = "C:\Chris\Office 2010\"
    
    Set oWB = Application.Workbooks.Open(sFilePath & "Names\Names.xlsx")
    Set oNameSheet = oWB.Worksheets("Names")
    
    
    Set oWB = Application.Workbooks.Open(sFilePath & "GradeBook.xlsx")
    Set oGradeSheet = oWB.Worksheets("Lab #")
    
    ThisWorkbook.Activate
    Application.ShowWindowsInTaskbar = False
    Application.ScreenUpdating = False
    
    For Each oCell In oNameSheet.Range(oNameSheet.Cells(2, 1), oNameSheet.Cells(2, 1).End(xlDown))
        sName = oCell.Value
        Set oWB = Application.Workbooks.Add
        
        oGradeSheet.Copy Before:=oWB.Worksheets(1)
        
        Application.DisplayAlerts = False
        With oWB
            .Worksheets(oWB.Worksheets.Count).Delete
            .Worksheets(oWB.Worksheets.Count).Delete
            .Worksheets(oWB.Worksheets.Count).Delete
            .Close True, sFilePath & "Grade Sheets\" & sName & ".xlsx"
        End With
        Application.DisplayAlerts = True
    Next oCell
    
    oGradeSheet.Parent.Close False
    oNameSheet.Parent.Close False
    
    Application.ShowWindowsInTaskbar = True
    Application.ScreenUpdating = True
End Sub

Function Centroid(oRng As Range, Optional sType As String) As Variant




    Dim vCoords As Variant
    Dim vRow() As Variant
    Dim i As Long
    Dim Area As Double
    Dim xPos As Double, yPos As Double
    
    vCoords = oRng.Value
    
    ReDim vRow(LBound(vCoords, 2) To UBound(vCoords, 2))
    
    For i = LBound(vCoords, 2) To UBound(vCoords, 2)
        vRow(i) = vCoords(1, i)
    Next i
    
    vCoords = AddRow(vCoords, vRow)
    
    Area = CalcArea(vCoords) 'Note that this is a signed area; if the points are numbered in clockwise order then the area will have a negative sign
    
    xPos = CalcxPos(vCoords, Area)
    yPos = CalcyPos(vCoords, Area)
    
    If UCase(sType) = "X" Then
        Centroid = xPos
    ElseIf UCase(sType) = "Y" Then
        Centroid = yPos
    ElseIf UCase(sType) = "AREA" Then
        Centroid = Abs(Area)
    ElseIf UCase(sType) = "SAREA" Then
        Centroid = Area
    Else
        Centroid = "(" & Round(xPos, 3) & "," & Round(yPos, 3) & ")"
    End If
    
    
End Function
Private Function CalcxPos(vCoords As Variant, Area As Double) As Double
    Dim i As Long
    
    For i = 1 To UBound(vCoords, 1) - 1
        CalcxPos = CalcxPos + (vCoords(i, 1) + vCoords(i + 1, 1)) * (vCoords(i, 1) * vCoords(i + 1, 2) - vCoords(i + 1, 1) * vCoords(i, 2))
    Next i
    
    CalcxPos = CalcxPos / (6 * Area)
    
End Function
Private Function CalcyPos(vCoords As Variant, Area As Double) As Double
    Dim i As Long
    
    For i = 1 To UBound(vCoords, 1) - 1
        CalcyPos = CalcyPos + (vCoords(i, 2) + vCoords(i + 1, 2)) * (vCoords(i, 1) * vCoords(i + 1, 2) - vCoords(i + 1, 1) * vCoords(i, 2))
    Next i
    
    CalcyPos = CalcyPos / (6 * Area)
    
End Function
Private Function CalcArea(vCoords As Variant) As Double
    Dim i As Long
    
    For i = 1 To UBound(vCoords, 1) - 1
        CalcArea = CalcArea + vCoords(i, 1) * vCoords(i + 1, 2) - vCoords(i + 1, 1) * vCoords(i, 2)
    Next i
    
    CalcArea = 0.5 * CalcArea
    
End Function
Private Function AddRow(InputArr As Variant, vRow As Variant) As Variant
    Dim vTemp As Variant
    Dim i As Long
    
    If LBound(vRow) <> LBound(InputArr, 2) Or UBound(vRow) <> UBound(InputArr, 2) Then AddRow = 0: Exit Function
    
    vTemp = TransposeArray(InputArr)
    
    ReDim Preserve vTemp(LBound(vTemp, 1) To UBound(vTemp, 1), LBound(vTemp, 2) To UBound(vTemp, 2) + 1)
    
    vTemp = TransposeArray(vTemp)
    
    For i = LBound(vTemp, 2) To UBound(vTemp, 2)
        vTemp(UBound(vTemp, 1), i) = vRow(i)
    Next i
    
    AddRow = vTemp
    
End Function
Private Function TransposeArray(InputArr As Variant) As Variant




Dim RowNdx As Long
Dim ColNdx As Long
Dim LB1 As Long
Dim LB2 As Long
Dim UB1 As Long
Dim UB2 As Long
Dim OutputArr() As Variant




LB1 = LBound(InputArr, 1)
LB2 = LBound(InputArr, 2)
UB1 = UBound(InputArr, 1)
UB2 = UBound(InputArr, 2)




ReDim OutputArr(LB2 To LB2 + UB2 - LB2, LB1 To LB1 + UB1 - LB1)




For RowNdx = LB2 To UB2
    For ColNdx = LB1 To UB1
        OutputArr(RowNdx, ColNdx) = InputArr(ColNdx, RowNdx)
    Next ColNdx
Next RowNdx




TransposeArray = OutputArr




End Function

Option Explicit
Dim lColumn As Long
Private Sub cmdCreate_Click()




    Dim lRow As Long, lCol As Long
    Dim lInsertRow As Long
    
    Dim oDetailSheet As Worksheet, oReportSheet As Worksheet
    Dim vTestValue As Variant
    
    Dim vData As Variant
    Dim vReportData() As Variant
    
    Set oDetailSheet = Sheet1 'Set to the detail sheet
    Set oReportSheet = Sheet2 'Set to the report sheet




    vTestValue = cmbReportType.Value
    
    If LastRow(oDetailSheet) < 3 Then Unload Me: Exit Sub 'Unload and Exit if there are no rows in data
    
    vData = oDetailSheet.Range(oDetailSheet.Cells(3, 1), oDetailSheet.Cells(3, 1).End(xlDown).End(xlToRight)).Value 'Store relevant data in array (Note: You might want to hardcode the fact that there are 4 columns)
    
    If LastRow(oReportSheet) > 2 Then oReportSheet.Range(oReportSheet.Cells(3, 1), oReportSheet.Cells(3, 1).End(xlDown).End(xlToRight)).EntireRow.Delete 'Clear relevant area in Report sheet




    lInsertRow = 0
    For lRow = LBound(vData, 1) To UBound(vData, 1)
        If CStr(vData(lRow, lColumn)) = CStr(vTestValue) Then
        
            lInsertRow = lInsertRow + 1
            
            ReDim Preserve vReportData(1 To UBound(vData, 2), 1 To lInsertRow) 'Array is transposed as you can only alter the last dimension of an array while preserving
            
            For lCol = LBound(vData, 2) To UBound(vData, 2)
                vReportData(lCol, lInsertRow) = vData(lRow, lCol)
            Next lCol
            
        End If
    Next lRow
    
    TransposeArray2D vReportData
    
    oReportSheet.Range(oReportSheet.Cells(3, 1), oReportSheet.Cells(3, 1)).Resize(UBound(vReportData, 1), UBound(vReportData, 2)).Value = vReportData
    
    Unload Me




End Sub
Private Sub UserForm_Initialize()
    
    Dim oDetailSheet As Worksheet
    Dim vColNames() As Variant
    
    Set oDetailSheet = Sheet1




    vColNames = oDetailSheet.Range(oDetailSheet.Cells(2, 1), oDetailSheet.Cells(2, 1).End(xlToRight)).Value
    
    TransposeArray2D vColNames
    
    cmbTestCol.List = vColNames
        
End Sub
Private Sub cmbTestCol_Change()
    
    Dim oDetailSheet As Worksheet
    Dim vReportTypes() As Variant




    Set oDetailSheet = Sheet1
    
    lColumn = cmbTestCol.ListIndex + 1
    
    vReportTypes = UniqueItems(oDetailSheet.Range(oDetailSheet.Cells(3, lColumn), oDetailSheet.Cells(2, lColumn).End(xlDown)).Value, True)
    
    cmbReportType.List = vReportTypes




End Sub
Private Function LastRow(oWS As Worksheet)
    LastRow = oWS.UsedRange.Rows.Count
      Do Until WorksheetFunction.CountA(oWS.Rows(LastRow)) <> 0 Or LastRow = 1
          oWS.Rows(LastRow).EntireRow.Delete
          LastRow = oWS.UsedRange.Rows.Count
      Loop
End Function
Private Sub TransposeArray2D(ByRef InputArr As Variant)
    Dim lRow As Long, lCol As Long
    Dim vTemp() As Variant
    
    If Not IsArray(InputArr) Then Exit Sub
    
    ReDim vTemp(LBound(InputArr, 2) To UBound(InputArr, 2), LBound(InputArr, 1) To UBound(InputArr, 1))




    For lRow = LBound(vTemp, 1) To UBound(vTemp, 1)
        For lCol = LBound(vTemp, 2) To UBound(vTemp, 2)
            vTemp(lRow, lCol) = InputArr(lCol, lRow)
        Next lCol
    Next lRow
    
    InputArr = vTemp
    
End Sub
Private Function UniqueItems(ByRef ArrayIn, Optional ByVal Sort As Boolean = True) As Variant




'   Accepts an array or range as input
    Dim Unique() As Variant ' array that holds the unique items
    Dim Element As Variant
    Dim i As Long
    Dim FoundMatch As Boolean
    Dim NumUnique As Long
'   Loop thru the input array
    For Each Element In ArrayIn
        FoundMatch = False
'       Has item been added yet?
        For i = 1 To NumUnique
            If Element = Unique(i) Then
                FoundMatch = True
                Exit For '(exit loop)
            End If
        Next i
'       If not in list, add the item to unique list
        If Not FoundMatch Then
            NumUnique = NumUnique + 1
            ReDim Preserve Unique(1 To NumUnique)
            Unique(NumUnique) = Element
        End If
    Next Element
'   Assign a value to the function
    If Sort = True Then QuickSort Unique
    For i = 1 To NumUnique
    If IsEmpty(Unique(i)) Then Unique(i) = "#Empty#"
    Next i
    UniqueItems = Unique
End Function
Private Sub QuickSort(ByRef lngArray() As Variant, Optional ByRef swapArray As Variant)
    Dim iLBound As Long
    Dim iUBound As Long
    Dim iTemp As Variant, iTemp2 As Variant
    Dim iOuter As Long
    Dim iMax As Long
    
    iLBound = LBound(lngArray)
    iUBound = UBound(lngArray)
    If Not IsMissing(swapArray) Then If LBound(swapArray) <> iLBound Or UBound(swapArray) <> iUBound Then Err.Raise 9
    
    'Dont want to sort array with only 1 value
    If (iUBound - iLBound) Then
        
        'Move the largest value to the rightmost position, otherwise
        'we need to check that iLeftCur does not exceed the bounds of the
        'array on EVERY pass (time consuming)
        iMax = 1
        For iOuter = iLBound To iUBound
            If lngArray(iOuter) > lngArray(iMax) Then iMax = iOuter
        Next iOuter
        
        iTemp = lngArray(iMax)
        If Not IsMissing(swapArray) Then iTemp2 = swapArray(iMax)
        lngArray(iMax) = lngArray(iUBound)
        If Not IsMissing(swapArray) Then swapArray(iMax) = swapArray(iUBound)
        lngArray(iUBound) = iTemp
        If Not IsMissing(swapArray) Then swapArray(iUBound) = iTemp2
    
        'Start quicksorting
        If Not IsMissing(swapArray) Then
            InnerQuickSort lngArray, iLBound, iUBound, swapArray
        Else
            InnerQuickSort lngArray, iLBound, iUBound
        End If
        
    End If
End Sub




Private Sub InnerQuickSort(ByRef lngArray() As Variant, ByVal iLeftEnd As Long, ByVal iRightEnd As Long, Optional ByRef swapArray As Variant)
    Dim iLeftCur As Long
    Dim iRightCur As Long
    Dim iPivot As Variant, iPivot2 As Variant
    Dim iTemp As Variant, iTemp2 As Variant
    
    If iLeftEnd >= iRightEnd Then Exit Sub
    
    iLeftCur = iLeftEnd
    iRightCur = iRightEnd + 1
    iPivot = lngArray(iLeftEnd)
    If Not IsMissing(swapArray) Then iPivot2 = swapArray(iLeftEnd)
    
    'Arrange values so that < pivot are on the left and > pivot are on the right
    Do
        'Find >= value on left side
        Do
            iLeftCur = iLeftCur + 1
        Loop While lngArray(iLeftCur) < iPivot
        
        'Find <= value on right side
        Do
            iRightCur = iRightCur - 1
        Loop While lngArray(iRightCur) > iPivot
        
        'No more swapping to do
        If iLeftCur >= iRightCur Then Exit Do
        
        'Swap
        iTemp = lngArray(iLeftCur)
        If Not IsMissing(swapArray) Then iTemp2 = swapArray(iLeftCur)
        lngArray(iLeftCur) = lngArray(iRightCur)
        If Not IsMissing(swapArray) Then swapArray(iLeftCur) = swapArray(iRightCur)
        lngArray(iRightCur) = iTemp
        If Not IsMissing(swapArray) Then swapArray(iRightCur) = iTemp2
    Loop
    
    'Call quicksort recursively on left and right subarrays
    lngArray(iLeftEnd) = lngArray(iRightCur)
    If Not IsMissing(swapArray) Then swapArray(iLeftEnd) = swapArray(iRightCur)
    lngArray(iRightCur) = iPivot
    If Not IsMissing(swapArray) Then swapArray(iRightCur) = iPivot2
    
    If Not IsMissing(swapArray) Then
        InnerQuickSort lngArray, iLeftEnd, iRightCur - 1, swapArray
        InnerQuickSort lngArray, iRightCur + 1, iRightEnd, swapArray
    Else
        InnerQuickSort lngArray, iLeftEnd, iRightCur - 1
        InnerQuickSort lngArray, iRightCur + 1, iRightEnd
    End If
End Sub

Sub Centroid()


    Dim oWS As Worksheet
    Dim vCoords As Variant
    Dim vRow() As Variant
    Dim i As Long
    Dim Area As Double
    Dim xPos As Double, yPos As Double
    
    Set oWS = Sheet1 'This should be the sheet where the (x,y) coords are stored in column 1 and 2 respectively with headers.
    
    vCoords = oWS.Range(oWS.Cells(2, 1), oWS.Cells(2, 1).End(xlDown).End(xlToRight)).Value
    
    ReDim vRow(LBound(vCoords, 2) To UBound(vCoords, 2))
    
    For i = LBound(vCoords, 2) To UBound(vCoords, 2)
        vRow(i) = vCoords(1, i)
    Next i
    
    vCoords = AddRow(vCoords, vRow)
    
    Area = CalcArea(vCoords)
    
    xPos = CalcxPos(vCoords, Area)
    yPos = CalcyPos(vCoords, Area)
    
    oWS.Cells(1, 5) = "x"
    oWS.Cells(1, 6) = "y"
    oWS.Cells(2, 4) = "Centroid:"
    oWS.Cells(2, 5) = xPos
    oWS.Cells(2, 6) = yPos




End Sub
Private Function CalcxPos(vCoords As Variant, Area As Double) As Double
    Dim i As Long
    
    For i = 1 To UBound(vCoords, 1) - 1
        CalcxPos = CalcxPos + (vCoords(i, 1) + vCoords(i + 1, 1)) * (vCoords(i, 1) * vCoords(i + 1, 2) - vCoords(i + 1, 1) * vCoords(i, 2))
    Next i
    
    CalcxPos = CalcxPos / (6 * Area)
    
End Function
Private Function CalcyPos(vCoords As Variant, Area As Double) As Double
    Dim i As Long
    
    For i = 1 To UBound(vCoords, 1) - 1
        CalcyPos = CalcyPos + (vCoords(i, 2) + vCoords(i + 1, 2)) * (vCoords(i, 1) * vCoords(i + 1, 2) - vCoords(i + 1, 1) * vCoords(i, 2))
    Next i
    
    CalcyPos = CalcyPos / (6 * Area)
    
End Function
Private Function CalcArea(vCoords As Variant) As Double
    Dim i As Long
    
    For i = 1 To UBound(vCoords, 1) - 1
        CalcArea = CalcArea + vCoords(i, 1) * vCoords(i + 1, 2) - vCoords(i + 1, 1) * vCoords(i, 2)
    Next i
    
    CalcArea = 0.5 * CalcArea
    
End Function
Private Function AddRow(InputArr As Variant, vRow As Variant) As Variant
    Dim vTemp As Variant
    Dim i As Long
    
    If LBound(vRow) <> LBound(InputArr, 2) Or UBound(vRow) <> UBound(InputArr, 2) Then AddRow = 0: Exit Function
    
    vTemp = TransposeArray(InputArr)
    
    ReDim Preserve vTemp(LBound(vTemp, 1) To UBound(vTemp, 1), LBound(vTemp, 2) To UBound(vTemp, 2) + 1)
    
    vTemp = TransposeArray(vTemp)
    
    For i = LBound(vTemp, 2) To UBound(vTemp, 2)
        vTemp(UBound(vTemp, 1), i) = vRow(i)
    Next i
    
    AddRow = vTemp
    
End Function
Private Function TransposeArray(InputArr As Variant) As Variant




Dim RowNdx As Long
Dim ColNdx As Long
Dim LB1 As Long
Dim LB2 As Long
Dim UB1 As Long
Dim UB2 As Long
Dim OutputArr() As Variant




LB1 = LBound(InputArr, 1)
LB2 = LBound(InputArr, 2)
UB1 = UBound(InputArr, 1)
UB2 = UBound(InputArr, 2)




ReDim OutputArr(LB2 To LB2 + UB2 - LB2, LB1 To LB1 + UB1 - LB1)




For RowNdx = LB2 To UB2
    For ColNdx = LB1 To UB1
        OutputArr(RowNdx, ColNdx) = InputArr(ColNdx, RowNdx)
    Next ColNdx
Next RowNdx




TransposeArray = OutputArr




End Function

Sub ClearBooks()    
    Dim oWB As Workbook
    Dim oWS As Worksheet
    Dim vBooks As Variant
    Dim sFilePath As String
    Dim i As Integer
     
    sFilePath = "FilePath"
    vBooks = Sheet1.Range("A12:A27").Value
    Append2D vBooks, ".xls"
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
     
On Error GoTo errH:
    For i = LBound(vBooks, 1) To UBound(vBooks, 1)
        Set oWB = Workbooks.Open(sFilePath & vBooks(i, 1))
        Set oWS = oWB.Sheets(1)
        oWS.Range("A2:H21").ClearContents
        oWS.Range("K4:P5").ClearContents
        oWB.Close SaveChanges:=True
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Exit Sub
errH:
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox Err.Description
End Sub




Private Sub Append2D(ByRef InputArr As Variant, sAppend As String)
    Dim i As Long, j As Long
    Dim vTemp() As Variant
    
    ReDim vTemp(LBound(InputArr, 1) To UBound(InputArr, 1), LBound(InputArr, 2) To UBound(InputArr, 2))
    
    For i = LBound(InputArr, 1) To UBound(InputArr, 1)
        For j = LBound(InputArr, 2) To UBound(InputArr, 2)
            vTemp(i, j) = InputArr(i, j) & sAppend
        Next j
    Next i
    
    InputArr = vTemp




End Sub