Public Sub Grade one report ()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.StatusBar = ">>>>>>>> The program is running >>>>>>>>" 'On Error GoTo ErrHandler Dim StartTime, UsedTime As Variant
StartTime = VBA.Timer Dim i%, k%, Arr, Brr
Dim Wb As Workbook
Dim Sht As Worksheet
Dim gSht As Worksheet
Dim Rng As Range
Dim mSht As Worksheet
Dim mRng As Range
Dim NewSht As Worksheet
Dim NewWb As Workbook
Dim EndRow As Long
Dim EndCol As Long
Dim myRng As Range
Dim SplitColumn As Long
Dim SplitDic As Object
Set SplitDic = CreateObject("scripting.dictionary")
Dim FolderPath As String
Dim FilePath As String
Const DataSheetName As String = " grade _ The total score of this time "
Const FileName As String = " grade _ Results report .xlsx"
Const HEAD_ROW As Long = 1
Const SplitColumnName As String = "C" Set Wb = Application.ThisWorkbook On Error Resume Next
Set OpenWb = Application.Workbooks(FileName)
If Not OpenWb Is Nothing Then OpenWb.Close True
On Error GoTo 0 Set mSht = Wb.Worksheets(" Honor list format ")
Set mRng = mSht.UsedRange FolderPath = Wb.Path & "\"
FilePath = FolderPath & FileName On Error Resume Next
Kill FilePath
On Error GoTo 0 Set NewWb = Application.Workbooks.Add
NewWb.SaveAs FileName:=FilePath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False Set Sht = Wb.Worksheets(DataSheetName)
With Sht
RankSort .UsedRange
End With
' The liberal arts score
NewWb.Worksheets(1).Name = " Grade total "
Sht.UsedRange.Copy NewWb.Worksheets(1).Range("A1") ' Average score and deviation rate
Wb.Worksheets(" grade _ The average separation rate of each subject ").Copy After:=NewWb.Worksheets(NewWb.Worksheets.Count) ' Split the score table to each class
With Sht
SplitColumn = Sht.Range(SplitColumnName & "1").Column
If .FilterMode = True Then .Cells.AutoFilter
EndRow = .Cells(.Rows.Count, SplitColumn).End(xlUp).Row
EndCol = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByColumns, xlPrevious).Column
Arr = .Cells(HEAD_ROW + 1, SplitColumn).Resize(EndRow - HEAD_ROW, EndCol).Value
For i = 1 To UBound(Arr)
If Arr(i, 1) <> "" Then
SplitDic(Arr(i, 1)) = ""
End If
Next
For Each Key In SplitDic.keys
If .FilterMode = True Then .Cells.AutoFilter
Set Rng = .Range("A" & HEAD_ROW).Resize(1, EndCol)
Rng.AutoFilter Field:=SplitColumn, Criteria1:=Key Set NewSht = NewWb.Worksheets.Add(After:=NewWb.Worksheets(NewWb.Worksheets.Count))
NewSht.Name = Key & " Cascade "
Set myRng = .UsedRange.SpecialCells(xlCellTypeVisible)
myRng.Copy NewSht.Range("A1")
NewSht.Columns.AutoFit For Each OneCell In NewSht.UsedRange.Cells
'If onecell.Value = "" Then onecell.Value = 0 Those who are absent will be left blank
Next OneCell .Cells.AutoFilter
Next Key
End With NewWb.Close True ' Save and close to form a new file , Easy to use SQL Inquire about Set NewWb = Application.Workbooks.Open(FilePath) ' And on again DataPath = FilePath
Dim CNN As Object
Dim RS As Object
Dim DATA_ENGINE As String
Select Case Application.Version * 1
Case Is <= 11
DATA_ENGINE = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=YES;IMEX=2';Data Source="
Case Is >= 12
DATA_ENGINE = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES;IMEX=2'; Data Source= "
End Select
Set CNN = CreateObject("ADODB.Connection")
Set RS = CreateObject("ADODB.RecordSet")
CNN.Open DATA_ENGINE & DataPath For Each OneSht In NewWb.Worksheets
Debug.Print OneSht.Name
If OneSht.Name Like "* Cascade *" Then
SQL = "SELECT full name , Chinese language and literature , Language arrangement , mathematics , Count the rows , English , Yingpai , Physics , Row of things , chemical , Huapai , biological , Raw pork , Politics , Political platoon , history , Calendar , Geography , Row on the floor , Total score , General platoon FROM [" & OneSht.Name & "$A1:Y] WHERE full name IS NOT NULL "
Debug.Print SQL
Set RS = CNN.Execute(SQL) Set NewSht = NewWb.Worksheets.Add(After:=NewWb.Worksheets(NewWb.Worksheets.Count))
NewSht.Name = Replace(OneSht.Name, " level ", " class ") With NewSht .Range("A1").Resize(1, 22).Value = Array(" full name ", " Chinese language and literature ", " Language arrangement ", " mathematics ", " Count the rows ", " English ", " Yingpai ", " Physics ", " Row of things ", " chemical ", " Huapai ", " biological ", " Raw pork ", " Politics ", " Political platoon ", " history ", " Calendar ", " Geography ", " Row on the floor ", " Total score ", " General platoon ", " Scheduling ")
.Range("A2").CopyFromRecordset RS EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
'EndCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column 'For j = 1 To EndCol
j = 22
'If .Cells(1, j).Text Like "* row " And Not .Cells(1, j).Text <> " General platoon " Then
'Set Rng = .Range("R2:R" & EndRow)
Set Rng = .Range(.Cells(2, j), .Cells(EndRow, j))
Rng.FormulaR1C1 = "=RANK(RC[-2],R2C[-2]:R" & EndRow & "C[-2])"
'End If
'Next j RankSort .UsedRange .UsedRange.Font.Size = 10 'For Each onecell In .UsedRange.Cells
' If IsNumeric(onecell.Value) Then onecell.Value = Format(onecell.Text, "0.0")
'Next onecell .Columns.AutoFit
SetBorders .UsedRange
SetCenters .UsedRange
'Sort_2003 .UsedRange, True, True, 18
End With
myPageSetup NewSht
End If
Next OneSht ' Stop NewWb.Close True
RS.Close
CNN.Close 'Stop Set NewWb = Application.Workbooks.Open(FilePath)
Set CNN = CreateObject("ADODB.Connection")
Set RS = CreateObject("ADODB.RecordSet")
CNN.Open DATA_ENGINE & DataPath
For Each OneSht In NewWb.Worksheets
If OneSht.Name Like "* Scheduling *" Then
' The honor roll
'Set lastSht = NewWb.Worksheets(NewWb.Worksheets.Count)
'mSht.Copy After:=lastSht
Set NewSht = NewWb.Worksheets.Add(After:=NewWb.Worksheets(NewWb.Worksheets.Count))
NewSht.Name = Replace(OneSht.Name, " Scheduling ", " The honor roll ")
mRng.Copy NewSht.Range("A1")
With NewSht
'SQL = "SELECT TOP 10 full name , Total score , Scheduling , General platoon FROM [" & OneSht.Name & "$A1:R] WHERE full name IS NOT NULL " SQL = "SELECT full name , Total score , Scheduling , General platoon FROM [" & OneSht.Name & "$A1:Y] WHERE Scheduling <=10 and full name IS NOT NULL "
Set RS = CNN.Execute(SQL)
Set Rng = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
.Range("A3").CopyFromRecordset RS
SetBorders .Range("A3").CurrentRegion ' Stop Sbj = Array(" Chinese language and literature ", " mathematics ", " English ", " Physics ", " chemical ", " biological ", " Politics ", " history ", " Geography ")
For n = LBound(Sbj) To UBound(Sbj) Step 1
i = .Cells(.Cells.Rows.Count, "G").End(xlUp).Row + 1
SQL = "SELECT MAX(" & Sbj(n) & ") FROM [" & OneSht.Name & "$A1:Y] WHERE " & Sbj(n) & " IS NOT NULL "
Debug.Print SQL
Set RS = CNN.Execute(SQL)
SCORE = Application.WorksheetFunction.Transpose(RS.GETROWS())
SQL = "SELECT full name ," & Sbj(n) & ", Total score ," & Left(Sbj(n), 1) & " row " & " FROM [" & OneSht.Name & "$A1:Y] WHERE " & Sbj(n) & "=" & SCORE(1) & " "
Set RS = CNN.Execute(SQL)
.Cells(i, "G").CopyFromRecordset RS
EndRow = .Cells(.Cells.Rows.Count, "G").End(xlUp).Row
For m = i To EndRow
.Cells(m, "F").Value = Sbj(n)
Next m
Next n
SetBorders .Cells(i, "F").CurrentRegion ' Adjust the format of the honor list 1
Set Rng = .Range("A1").CurrentRegion
Set Rng = Application.Intersect(Rng.Offset(1), Rng)
Arr = Rng.Value
Dim Ar() As String
ReDim Ar(1 To UBound(Arr) * 2 - 2, 1 To UBound(Arr, 2))
For i = LBound(Arr) + 1 To UBound(Arr)
n = (i - 2) * 2 + 1
For j = LBound(Arr, 2) To UBound(Arr, 2)
Ar(n, j) = Arr(1, j)
Ar(n + 1, j) = Arr(i, j)
Next j
Next i
Set Rng = .Range("A2")
Set Rng = Rng.Resize(UBound(Ar), UBound(Ar, 2))
Rng.Value = Ar
SetBorders Rng ' Adjust the format of the honor list 2
Set Rng = .Range("F1").CurrentRegion
Set Rng = Application.Intersect(Rng.Offset(1), Rng)
Arr = Rng.Value ReDim Ar(1 To UBound(Arr) * 2 - 2, 1 To UBound(Arr, 2))
For i = LBound(Arr) + 1 To UBound(Arr)
n = (i - 2) * 2 + 1
For j = LBound(Arr, 2) To UBound(Arr, 2)
Ar(n, j) = Arr(1, j)
Ar(n + 1, j) = Arr(i, j)
Next j
Next i
Set Rng = .Range("F2")
Set Rng = Rng.Resize(UBound(Ar), UBound(Ar, 2))
Rng.Value = Ar SetBorders Rng
SetCenters .UsedRange End With
myPageSetup NewSht
End If
Next OneSht
NewWb.Close True
RS.Close
CNN.Close UsedTime = VBA.Timer - StartTime
Debug.Print "UsedTime :" & Format(UsedTime, "#0.0000 Seconds")
'MsgBox "UsedTime :" & Format(UsedTime, "#0.0000 Seconds") ErrorExit:
Set Wb = Nothing
Set Sht = Nothing
Set Rng = Nothing Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
Exit Sub
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
ErrHandler:
If Err.Number <> 0 Then
MsgBox Err.Description & "!", vbCritical, " QQ 84857038"
'Debug.Print Err.Description
Err.Clear
Resume ErrorExit
End If
End Sub
Public Sub myPageSetup(ByVal Sht As Worksheet)
With Sht.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
.PrintArea = ""
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.236220472440945)
.RightMargin = Application.InchesToPoints(0.236220472440945)
.TopMargin = Application.InchesToPoints(0.354330708661417)
.BottomMargin = Application.InchesToPoints(0.354330708661417)
.HeaderMargin = Application.InchesToPoints(0.31496062992126)
.FooterMargin = Application.InchesToPoints(0.31496062992126)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlPortrait
.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
End Sub
Public Function RegGet(ByVal OrgText As String, ByVal Pattern As String) As String
' Pass parameters : Original string , Matching mode
Dim Regex As Object
Dim Mh As Object
Set Regex = CreateObject("VBScript.RegExp")
With Regex
.Global = True
.Pattern = Pattern
End With
If Regex.test(OrgText) Then
Set Mh = Regex.Execute(OrgText)
RegGet = Mh.Item(0).submatches(0)
Else
RegGet = ""
End If
Set Regex = Nothing
End Function
Sub TestRegGet()
Debug.Print RegGet(Sbj, "\d+")
End Sub Private Sub RankSort2(ByVal Rng As Range, Optional WithHeader As Boolean = True)
With Rng 'xlAscending
.Sort _
Key1:=Rng.Cells(1, 3), Order1:=xlAscending, _
Key2:=Rng.Cells(1, 23), Order2:=xlAscending, _
Header:=xlYes, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin
End With
End Sub Private Sub RankSort(ByVal Rng As Range, Optional WithHeader As Boolean = True)
With Rng 'xlAscending
.Sort _
Key1:=Rng.Cells(1, 22), Order1:=xlAscending, _
Header:=xlYes, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin
End With
End Sub

20181013xlVba More articles on grade report

  1. 20181013xlVba Performance report optimization

    Public Sub Performance report optimization () Application.ScreenUpdating = False Application.DisplayAlerts = False Application ...

  2. 20181013xlVba Grade report is divided into class report

    ' Grade report is divided into class report Public Sub CreateClassReport() Application.DisplayAlerts = False Dim Wb As Workbook Dim ...

  3. 20181013xlVba Lead in grades

    Sub Lead in grades () Const TargetSheet = " grade _ Original score summary " Const DesSheet = " grade _ The total score of this time " Applicat ...

  4. 20181013xlVba Generate a picture file according to the score bar

    Sub CreateGoalPictures() ' Declare variables Dim Wb As Workbook Dim Sht As Worksheet Dim Shp As Shape Dim Pic, End ...

  5. Use FineReport Build test analysis system

    The advantages of this system : 1. The report is rich in content : Total score analysis is included in the system . Sub analysis . Make a wrong answer . Test paper proposition analysis and five kinds of user reports . It covers all kinds of analysis data needed by the school , And provide rich charts , Make the analysis data more intuitive . 2. The operation is flexible and simple ...

  6. Gridview forward

    home page Open source project Question and answer move Blog translate information project City circle [ Sign in | register ] Blog zone > Reya Dripping heart blog details Asp.net in GridView The use of, ( Very comprehensive , Very classic ) Reya Dripping water ...

  7. Asp.net in GridView The use of, ( lead )

    GridView No code paging sort GridView Choose , edit , Cancel , Delete GridView Sort in both directions GridView And pull-down menus DropDownList combination GridView and CheckBox Combined with mouse move to Gr ...

  8. 【 turn 】 GridView 72 It's like a stunt

    explain : Prepare a series , In essence C# Language points . There's no sequence in this series , But try to be precise . It may be constantly added, deleted and sorted out , The original source of this series is csdn Blog , Thank you for your attention . C# quintessence Lesson four GridView 72 It's like a stunt author ...

  9. GridView Detailed usage

    l GridView No code paging sort l GridView Choose , edit , Cancel , Delete l GridView Sort in both directions l GridView And pull-down menus DropDownList combination l GridView and Ch ...

Random recommendation

  1. Android Studio Run appears Error:Execution failed for task &#39;:app:transformResourcesWithMergeJavaResForDebug&#39;.

    Reprint please indicate the source : http://www.cnblogs.com/why168888/p/5978381.html  This article from the :[Edwin Blog Garden ] I quote compile 'com.squareup.re ...

  2. note-&gt;notice

    Log in to the blog Park , At first glance, the date of the last blog is 2 End of month , Now it is 5 month , I want to record something several times during this period , I always feel that the 24-hour day is getting shorter and shorter , Several times I have to reset my password to log in ... It's been two months since the manager ...

  3. I understand. C++ Virtual function table

    Today I read Chen Hao's C++ Virtual function table analysis article , Feeling for C++ We have a little understanding of the inheritance and polymorphism of , Write down your understanding here . If something's wrong , Welcome to correct . If for C++ If you don't know the virtual function table , Please read Chen Hao's C++ Virtual function table analysis ...

  4. Use GruntJS structure Web Program

    Gruntjs yes JavaScript Project building tools , Is based on node A command line tool for . A lot of open source JS Projects are built with it . Such as jQuery.Qunit.CanJS etc. . It has the following functions Merge JS file Compress JS file ...

  5. Database performance optimization I :SQL Index in one step

    SQL Index plays a very important role in database optimization ,  A good index design , It can improve your efficiency dozens or even hundreds of times , Here will take you step by step to uncover his mystery . 1.1  What is index ? SQL There are two kinds of indexes , Clustered and non-clustered indexes ...

  6. 【JAVA Coding topics 】 JAVA Character encoding series three :Java Coding problems in applications

    Take the time to sum up these two days / Sort out the actual coding methods of various codes , And in Java Usage in applications , Write it down here for future reference . In order to form a complete understanding and in-depth grasp of character coding , In order to deal with Java Problems encountered in the development process ...

  7. Customize View Compile failed .Binary XML file line #255: Error inflating

    02-28 15:17:16.281: DEBUG/AndroidRuntime(391): Shutting down VM 02-28 15:17:16.281: WARN/dalvikvm(39 ...

  8. js Take the maximum value of one-dimensional array , minimum value

    Recently encountered in the project , Dealing with array data :     var newStrs=[1,2,3,4];               alert(Math.min.apply(null,newStrs));  // ...

  9. Xamarin And A collection of environmental errors

    error message :   connection of the layout renderer failed.this may be caused by a misconfiguration of java .p ...

  10. Python The journey . The third chapter . function 3.27

    One . Formal parameter and actual parameter 1. What are formal parameters and actual parameters ? Shape parameter ( Formal parameters ): refer to When you define a function , Parameters defined in brackets , Parameter is actually variable name Actual parameters ( The actual parameter ), refer to When the function is called , The value passed in parentheses , The argument is actually the value of the variable x,y yes ...