Public Sub 高一成绩报表()

    Application.ScreenUpdating = False

    Application.DisplayAlerts = False

    Application.Calculation = xlCalculationManual

    Application.StatusBar = ">>>>>>>>程序正在运行>>>>>>>>"

    '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 = "年级_本次成绩总表"

    Const FileName As String = "年级_成绩报表.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("光荣榜格式")

    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

    '文科成绩总表

    NewWb.Worksheets(1).Name = "年级总成绩"

    Sht.UsedRange.Copy NewWb.Worksheets(1).Range("A1")

    '平均分与离均率

    Wb.Worksheets("年级_各科离均率").Copy After:=NewWb.Worksheets(NewWb.Worksheets.Count)

    '拆分成绩总表到各个班级

    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 & "级排"

            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 缺考的留空

            Next OneCell

            .Cells.AutoFilter

        Next Key

    End With

    NewWb.Close True '保存关闭形成新文件，方便使用SQL查询

    Set NewWb = Application.Workbooks.Open(FilePath) '再打开

    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 "*级排*" Then

            SQL = "SELECT  姓名,语文,语排,数学,数排,英语,英排,物理,物排,化学,化排,生物,生排,政治,政排,历史,历排,地理,地排,总分,总排 FROM [" & OneSht.Name & "$A1:Y]    WHERE  姓名 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, "级", "班")

            With NewSht

                .Range("A1").Resize(1, 22).Value = Array("姓名", "语文", "语排", "数学", "数排", "英语", "英排", "物理", "物排", "化学", "化排", "生物", "生排", "政治", "政排", "历史", "历排", "地理", "地排", "总分", "总排", "班排")

                .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 "*排" And Not .Cells(1, j).Text <> "总排" 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 "*班排*" Then

            '光荣榜

            '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, "班排", "光荣榜")

            mRng.Copy NewSht.Range("A1")

            With NewSht

                'SQL = "SELECT  TOP 10 姓名,总分,班排,总排 FROM [" & OneSht.Name & "$A1:R]    WHERE  姓名 IS NOT NULL  "

                SQL = "SELECT   姓名,总分,班排,总排 FROM [" & OneSht.Name & "$A1:Y]    WHERE  班排<=10 and  姓名 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("语文", "数学", "英语", "物理", "化学", "生物", "政治", "历史", "地理")

                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  姓名," & Sbj(n) & ",总分," & Left(Sbj(n), 1) & "排" & " 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

                '调整光荣榜格式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

                '调整光荣榜格式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

'传递参数 ：原字符串， 匹配模式

    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