20171104xlVBA production of joint performance strips

Dim dgoal As ObjectDim Dcls as objectsub production Joint score Bar () Dim sht As Worksheet Dim headrng As Range Dim Header As Va Riant Dim Arr As Variant Dim Brr As Variant Set sht = Thisworkbook.worksheets ("Score Bar template") Set headrng = SHT.R Ange ("a1:z1") Header = Headrng.value ARR = getclass () BRR = Getexam () Set dgoal = CreateObject ("Scripting.dict    Ionary ") Set Dcls = CreateObject (" Scripting.Dictionary ") call Getgoal ' Debug.Print UBound (arr)-LBound (arr) + 1 For i = LBound (arr) to UBound (arr) ' Debug.Print arr (i) SheetName = CStr (arr (i)) Set Sht = Createsh (ThisWorkbook, SheetName) with Sht-OneKey in Dcls.keys If dcls (OneKey ) = SheetName then Endrow =. Cells (. Cells.Rows.Count, 2). End (Xlup).  Row + 2 If endrow = 3 Then Endrow = 1 ' Debug.Print endrow Set Rng = . Cells (Endrow, 1) Set Rng = rng.resize(UBound (header), UBound (header, 2)) Rng.value = Header Set Rng =. Cells (Endrow, 1). Offset (1, 1). Resize (UBound (BRR), 1) Rng.value = Application.WorksheetFunction.Transpose (BRR) Set Rng =. Cells (Endrow, 1).                    CurrentRegion ar = Rng.value ar (2, 1) = "Senior" & SheetName & "Class" AR (3, 1) = "'" & OneKey Ar (4, 1) = Dgoal (AR (2, 2) & ";" & OneKey & ";" & "Name" ) for x = LBound (AR) + 1 to UBound (AR) for y = LBound (AR, 2) + 2 to UBound (AR, 2 ) Key = AR (x, 2) & ";" & OneKey & ";" & AR (1, y) ar (                    x, y) = Dgoal (Key) Next y next x rng.value = Ar           Setborders rng setcenters rng End If Next OneKey             . UsedRange.Columns.AutoFit for each onerow in. Usedrange.rows onerow.rowheight = 16.5 Next onerow with. PageSetup. PrintTitleRows = "". PrintTitleColumns = "". PrintArea = "". LeftHeader = "". CenterHeader = "". RightHeader = "". LeftFooter = "". CenterFooter = "". RightFooter = "". LeftMargin = application.inchestopoints (0.7). RightMargin = application.inchestopoints (0.7). TopMargin = application.inchestopoints (0.75). BottomMargin = application.inchestopoints (0.75). HeaderMargin = application.inchestopoints (0.3). FooterMargin = application.inchestopoints (0.3). PrintHeadings = False. PrintGridlines = False. PrintComments = XlprintnocOmments. PrintQuality = 600. centerhorizontally = False. centerhorizontally = True. centervertically = True. Orientation = Xllandscape. Draft = False. PaperSize = xlPaperA4. FirstPageNumber = xlautomatic. Order = Xldownthenover. BlackAndWhite = False. Zoom = 100. PrintErrors = xlprinterrorsdisplayed. OddAndEvenPagesHeaderFooter = False. DifferentFirstPageHeaderFooter = False. Scalewithdocheaderfooter = True. Alignmarginsheaderfooter = True. EvenPage.LeftHeader.Text = "". EvenPage.CenterHeader.Text = "". EvenPage.RightHeader.Text = "". EvenPage.LeftFooter.Text = "". EvenPage.CenterFooter.Text = "". EvenPage.RightFooter.Text = "". Firstpage.leftheadEr. Text = "". FirstPage.CenterHeader.Text = "". FirstPage.RightHeader.Text = "". FirstPage.LeftFooter.Text = "". FirstPage.CenterFooter.Text = "". FirstPage.RightFooter.Text = "" End with.        Activate ActiveWindow.View = Xlpagebreakpreview activewindow.zoom = End with Next i Set dgoal = Nothing Set dcls = Nothing End subprivate Sub getgoal () Dim Onesht As Worksheet Dim examname        As String Dim stdId As String Dim stdname As String Dim StdClass As String Dim endrow As Long, endcol as Long                For each onesht in thisworkbook.worksheets If onesht.name like "score table *" Then with Onesht Examname = Replace (. Name, "score Table _", "" ") Endrow =. Cells (. Cells.Rows.Count, 1). End (Xlup). Row Endcol =. Cells (1,. Cells.Columns.Count). End (xlToLeft). Column for i =2 to Endrow stdId = CStr (. Cells (i, 1). Text) ' Debug.Print stdId stdname = CStr (. Cells (i, 2). Text) Stdcls = CStr (. Cells (i, 3).                        Text) dcls (stdId) = Stdcls for J = 1 to Endcol Key = Examname & ";" & StdId & ";" &. Cells (1, J). Text ' Debug.Print key Dgoal (key) =. Cells (i, J). Text Next J Next i end With end If next Oneshtend subprivate functi On GetClass () as Variant Dim Onesht As Worksheet Dim Cls As String, Tmp as String for each Onesht in ThisWorkbook . Worksheets If onesht.name like "score table *" then with onesht Endrow =. Cells (. Cells.Rows.Count, 3). End (Xlup). Row for i = 2 to Endrow Tmp = "|" &. Cells (i, 3).      Text                  If InStr (CLS, tmp) = 0 Then cls = CLS & TMP End If Next i end with End If next Onesht cls = Mid (CLS, 2) Debug.Print CLS GETCL The "The" (Cls, "|") End functionpublic Function createsheet (ByVal Wb as Workbook, ByVal SheetName as String) as Worksheet APPLICATION.DISPL Ayalerts = False Dim Newsht as Worksheet, Lastsht as Worksheet on Error Resume Next Set Newsht = wb.worksheets (Sh Eetname) If not Newsht are nothing then newsht.delete on Error GoTo 0 Set lastsht = wb.worksheets (Wb.Worksheets.Co UNT) Set Newsht = Wb.Worksheets.Add (after:=lastsht) newsht.name = SheetName Set createsheet = Newsht Set lasts HT = Nothing Set Newsht = Nothing Set Wb = Nothing Application.DisplayAlerts = TrueEnd Functionprivate Function G Etexam () as Variant Dim Ar () As String Dim i as Long i = 0 ReDim Ar (1 to 1) for each onesht in Th IsWOrkbook. Worksheets If onesht.name like "score table *" Then i = i + 1 examname = Replace (Onesh T.name, "score Table _", "" ") ReDim Preserve ar (1 to i) ar (i) = Examname End If Ne XT Onesht Getexam = Arend functionprivate Sub setborders (ByVal Rng as Range) with Rng.borders. LineStyle = xlcontinuous. ColorIndex = xlautomatic. TintAndShade = 0. Weight = Xlthin End withend subprivate Sub setcenters (ByVal rng as Range) with Rng. HorizontalAlignment = Xlcenter. VerticalAlignment = Xlcenter End withend Sub

　　

20171104xlVBA production of joint performance strips