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