20171104xlVBA制作联合成绩条

Posted 2020-10-13 Excel VBA 小天地

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