20171104xlVBA and Retreat Comparison

Tag:.so   add   color   des    Get     horizon   rank   not   tom   

Sub comparison to two scores () Createadvance "Retreat", "Monthly Exam 2", "Midterm", "Monthly Exam 2", "Monthly exam 3" End SubSub Createadvance (ByVal mainname as String, ByVal S    HtName1 As String, ByVal ShtName2 As String _, ByVal ExamName1 As String, ByVal ExamName2 as String) Dim Ar, Br Dim sht As Worksheet Dim Arr () As Variant Dim DNo As Object Dim drank as Object Dim drow As Object Dim Onek EY Dim Key as String Const start_col as Long = 4 Set sht = Thisworkbook.worksheets (mainname) Set dNo = Cre Ateobject ("Scripting.Dictionary") Set drank = CreateObject ("Scripting.Dictionary") Set Drow = CreateObject ("Scriptin G.dictionary ") ' Get results array Ar = GetArray (ShtName1, 0," a "," s ") Br = GetArray (ShtName2, 0," a "," s ") ' for i = LBound (AR) + 1 to UBound (AR) Step 1 Key = CStr (AR (i, 1)) DNo (Key) = Array (AR (i, 1), AR (i, 2), AR (i, 3) ' Storage number class information for J = LBound (AR, 2) to UBound (AR, 2) K = key & ExamName1 & Ar (1, J) ' Create keyword number  & Exam Name & account/Rank          ' Debug.Print K Drank (k) = Ar (i, J) ' stores all information next J next i for i = LBound (Br) + 1 to Uboun D (Ar) Step 1 Key = CStr (BR (I, 1)) DNo (Key) = Array (BR (I, 1), BR (I, 2), BR (I, 3)) ' Stored number class information for J =            LBound (BR, 2) to UBound (BR, 2) K = key & ExamName2 & Br (1, J) ' Create keyword study number & Test name & account/Rank ' Debug.Print K Drank (k) = Br (i, J) ' Store all information next J Next i ' Redefine merged scores table array number of students + Heading 1 The number for each section of the 4 column only retains the rank column so/2 ReDim ARR (1 to Dno.count + 1, 1 to (UBound (Ar, 2)-Start_col + 1)/2 * 4 + start_col-1) ' Debug . Print UBound (arr, 2) for j = 1 to Start_col-1 Arr (1, j) = Ar (1, j) Next J ' prepare new header x = 0 for j = STA  Rt_col to UBound (AR, 2) If ar (1, J) like "* Platoon *" then x = x + 1 y = (start_col-1) + (x-1) * 4 + 1 arr (1, y) = ExamName1 & AR (1, j) Arr (1, y + 1) = ExamName2 & AR (1, j) Arr ( 1, y + 2) = Ar (1, J) &Amp "Retreat Range" Arr (1, y + 3) = Ar (1, J) & "Advance and retreat rankings" End If Next J ' Assign the student information in the dictionary to the array i = 1 for Eac        H OneKey in Dno.keys i = i + 1 ar = dNo (OneKey) arr (i, 1) = CStr (Ar (0)) arr (i, 2) = Ar (1) Arr (i, 3) = Ar (2) for J = Start_col to UBound (arr, 2) If arr (1, J) like "* Platoon" then Key = CStr (Arr (i, 1)) & Arr (1, j) ' Debug.Print Key arr (i, j) = Drank (Key) ElseIf  Arr (1, j) like "* amplitude" then ARR (i, J) = Val (arr (i, J-2))-Val (arr (i, J-1)) End If Next J Next OneKey ' Division section inserts a ranking formula with Sht for the retreat stride. Cells.clear Set Rng =. Cells (1, 1) Set Rng = Rng.resize (UBound (arr), UBound (arr, 2)) Rng.value = Arr sort_2003 Rng, True, Tr UE, 3 arr = Rng.value for i = LBound (arr) + 1 to UBound (arr) Key = CStr (arr (i, 3)) If Not drow.exists (Key) Then Ar = ArraY (i, 0) drow (key) = ar Else ar = drow (key) ar (1) = I Drow (Key) = Ar End If Next i for J = 1 to UBound (arr, 2) If arr (1, J) like " * Rank "then for each OneKey in Drow.keys Ar = Drow (OneKey) StartRow = A R (0) Endrow = Ar (1) Set onerng =. Range (. Cells (StartRow, J),.        Cells (Endrow, J)) Addrankformula onerng, StartRow, Endrow Next OneKey End If Next J ' copy paste substitution formula arr = rng.value rng.value = Arr ' Format adjustment Rng.Columns.AutoF It setborders rng setcenters rng End with Set dNo = Nothing Set drank = Nothing Set sht = No Thing Set Rng = Nothing End subpublic Function GetArray (ByVal sheetname as String, ByVal Headrow as Long, ByVal Star Tcol As String, ByVal Endcol as String) as VarIant Dim Sht As Worksheet Dim Rng As Range Dim Arr As Variant Set sht = thisworkbook.worksheets (sheetname) With Sht Endrow =. Cells (. Cells.Rows.Count, Startcol). End (Xlup). Row Set Rng =. Range (. Cells (Headrow + 1, startcol),.    Cells (Endrow, endcol)) arr = Rng.value GetArray = arr End with Set Rng = Nothing Set Sht = Nothing Erase arrend functionpublic Sub sort_2003 (ByVal Rng as Range, Optional withheader as Boolean = True, Optional orderbyas cending as Boolean = True, Optional sortcolumnno as Long = 1) with Rng.            Sort _ Key1:=rng.cells (1, Sortcolumnno), Order1:=iif (orderbyascending, xlascending, xldescending), _ Header:=iif (Withheader, XlYes, XlNo), Matchcase:=false, Orientation:=xltoptobottom, Sortmethod:=xlpinyin End WithEnd S Ubsub Addrankformula (ByVal Rng as Range, ByVal StartRow as Long, ByVal Endrow as long) RNG.FORMULAR1C1 = "=rank (rc[-1), R "& StartRow &" C[-1]:r "& Endrow &" C[-1]) " End subpublic Sub setborders (ByVal Rng as Range) with Rng.borders. LineStyle = xlcontinuous. ColorIndex = xlautomatic. TintAndShade = 0. Weight = Xlthin End withend subpublic Sub setcenters (ByVal rng as Range) with Rng. HorizontalAlignment = Xlcenter. VerticalAlignment = Xlcenter End withend Sub

　　

20171104xlVBA and Retreat Comparison