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