20181013xlVba年级成绩报表

Posted 2021-01-12 nextseven

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