Dim dGoal As Object
Dim dCls As Object
Sub 制作联合成绩条() Dim sht As Worksheet
Dim HeadRng As Range
Dim Header As Variant
Dim Arr As Variant
Dim Brr As Variant Set sht = ThisWorkbook.Worksheets("成绩条模板")
Set HeadRng = sht.Range("A1:Z1")
Header = HeadRng.Value
Arr = GetClass()
Brr = GetExam()
Set dGoal = CreateObject("Scripting.Dictionary")
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 = CreateSheet(ThisWorkbook, SheetName) With sht
For Each 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) = "高三" & SheetName & "班"
Ar(3, 1) = "'" & OneKey
Ar(4, 1) = dGoal(Ar(2, 2) & ";" & OneKey & ";" & "姓名")
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 = 100
End With
Next i Set dGoal = Nothing
Set dCls = Nothing End Sub
Private 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 "成绩表*" Then
With OneSht
ExamName = Replace(.Name, "成绩表_", "")
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 OneSht
End Sub
Private Function GetClass() As Variant
Dim OneSht As Worksheet
Dim Cls As String, Tmp As String
For Each OneSht In ThisWorkbook.Worksheets
If OneSht.Name Like "成绩表*" 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
GetClass = Split(Cls, "|")
End Function
Public Function CreateSheet(ByVal Wb As Workbook, ByVal SheetName As String) As Worksheet
Application.DisplayAlerts = False
Dim NewSht As Worksheet, LastSht As Worksheet
On Error Resume Next
Set NewSht = Wb.Worksheets(SheetName)
If Not NewSht Is Nothing Then NewSht.Delete
On Error GoTo 0
Set LastSht = Wb.Worksheets(Wb.Worksheets.Count)
Set NewSht = Wb.Worksheets.Add(after:=LastSht)
NewSht.Name = SheetName
Set CreateSheet = NewSht
Set LastSht = Nothing
Set NewSht = Nothing
Set Wb = Nothing
Application.DisplayAlerts = True
End Function
Private Function GetExam() As Variant
Dim Ar() As String
Dim i As Long
i = 0
ReDim Ar(1 To 1)
For Each OneSht In ThisWorkbook.Worksheets
If OneSht.Name Like "成绩表*" Then
i = i + 1
ExamName = Replace(OneSht.Name, "成绩表_", "")
ReDim Preserve Ar(1 To i)
Ar(i) = ExamName
End If
Next OneSht
GetExam = Ar
End Function
Private Sub SetBorders(ByVal Rng As Range)
With Rng.Borders
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
End Sub
Private Sub SetCenters(ByVal Rng As Range)
With Rng
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End Sub