20181013xlVba成绩报表优化

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 GoalSht As Worksheet
    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, 24).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 = 24
                '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

    Set NewWb = Application.Workbooks.Open(FilePath)
    'Stop

   ModelAddress = "A1:L4"
    Set xSht = Wb.Worksheets("单次成绩条模板")
    Set xRng = xSht.Range(ModelAddress)

    Dim dGoal As Object

    For Each OneSht In NewWb.Worksheets
        If OneSht.Name Like "*班排*" Then
            '制作成绩条
            With OneSht
                '读取学生成绩
                Set dGoal = CreateObject("Scripting.Dictionary")

                EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
                For i = 2 To EndRow
                    Key = Key & ";" & .Cells(i, 1).Value
                    dGoal(Key) = .Cells(i, 1).Resize(1, 24).Value
                Next i

                '新建工作表 输出成绩
                Set GoalSht = NewWb.Worksheets.Add(after:=NewWb.Worksheets(NewWb.Worksheets.Count))
                GoalSht.Name = Replace(OneSht.Name, "班排", "成绩条")
                With GoalSht
                    For Each OneGoal In dGoal.keys

                        Brr = dGoal(OneGoal)
                        EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row + 2
                        If EndRow = 3 Then EndRow = 1
                        xRng.Copy .Cells(EndRow, 1)
                        .Cells(EndRow + 1, "A").Value = ExamName
                        .Cells(EndRow + 1, "B").Value = Brr(1, 24)
                        .Cells(EndRow + 3, "A").Value = Brr(1, 3)
                        .Cells(EndRow + 3, "B").Value = Brr(1, 2)
                        .Cells(EndRow + 1, "C").Resize(1, 10).Value = Array(Brr(1, 4), Brr(1, 6), Brr(1, 8), Brr(1, 10), Brr(1, 12), Brr(1, 14), Brr(1, 16), Brr(1, 18), Brr(1, 20), Brr(1, 22))
                        .Cells(EndRow + 3, "C").Resize(1, 10).Value = Array(Brr(1, 5), Brr(1, 7), Brr(1, 9), Brr(1, 11), Brr(1, 13), Brr(1, 15), Brr(1, 17), Brr(1, 19), Brr(1, 21), Brr(1, 23))
                    Next OneGoal

                                '.UsedRange.Columns.AutoFit
            .Rows.RowHeight = 16 'mSht.Range("O2").Value
            .UsedRange.Font.Size = 9 ' mSht.Range("O4").Value
            .UsedRange.Font.Name = "Arial" 'mSht.Range("O3").Value

                End With
                        CustomPageSetUp GoalSht

        AutoAdjustRowHeightBaseOnModel xSht, GoalSht, 9
         AutoAdjustColumnWidthBaseOnModel xSht, GoalSht, 1

            End With
        End If
    Next OneSht

    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, 24), Order1:=xlAscending, _
            Header:=xlYes, _
            MatchCase:=False, _
            Orientation:=xlTopToBottom, _
            SortMethod:=xlPinYin
    End With
End Sub

Public Sub CustomPageSetUp(ByVal Sht As Worksheet)
    With Sht.PageSetup
        .PrintArea = ""
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.25)
        .RightMargin = Application.InchesToPoints(0.25)
        .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
        .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
    End With
End Sub

Sub AutoAdjustRowHeightBaseOnModel(ByVal ModelSheet As Worksheet, ByVal PrintSheet As Worksheet, Optional modelCountInOnePage As Variant)
    Dim ModelRng As Range '模板单元格
    Dim modelRowHeight() As Double '模板行高数据
    Dim modelRowCount As Long '模板行数
    Dim sumModelRowHeight As Double '模板累计行高
    Dim adjustScale As Double '调整比例
    'Dim modelCountInOnePage As Long '一页打印几个单据模板
    Dim BreakRow As Long  '水平分页符位置
    Dim FirstPageSumRowHeight As Double '累计首页行高
    Dim RowsInOnePage  As Long  '每页打印多少行
    Dim i As Long, m As Long '行号

    With ModelSheet
        Debug.Print .Name
        'If Application.WorksheetFunction.Count(.Cells) > 0 Then
            '计数防止计算行号发生错误
            EndRow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row + 1
            EndCol = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByColumns, xlPrevious).Column
            '获取单据模板单元格区域
            Set ModelRng = .Range(.Cells(1, 1), .Cells(EndRow, EndCol))
            Debug.Print ModelRng.Address
            '获取模板单元格行数和累计行高
            modelRowCount = ModelRng.Rows.Count
            ReDim modelRowHeight(1 To modelRowCount)
            sumModelRowHeight = 0
            For i = 1 To modelRowCount
                modelRowHeight(i) = ModelRng.Rows(i).RowHeight
                sumModelRowHeight = sumModelRowHeight + ModelRng.Rows(i).RowHeight
            Next i
            Debug.Print "模板行高："; sumModelRowHeight
            '记录行高
        'End If
    End With

    With PrintSheet
        '获取第一页与第二页分页符所在的单元格
        If .HPageBreaks.Count > 0 Then
            BreakRow = .HPageBreaks(1).Location.Row
            Debug.Print "首页分页符所在的行号："; BreakRow
            '累计第一页所有行的高度
            i = 1
            Do While i < BreakRow
                FirstPageSumRowHeight = FirstPageSumRowHeight + .Rows(i).RowHeight
                i = i + 1
            Loop

            Debug.Print "页面高度："; FirstPageSumRowHeight
            '获取第一页最后一个成绩单末尾的空白行行号
            If IsMissing(modelCountInOnePage) Then
                RowsInOnePage = BreakRow
                Do While Application.WorksheetFunction.Count(.Rows(RowsInOnePage)) > 0
                    RowsInOnePage = RowsInOnePage - 1
                Loop
                'Debug.Print "首页最后一个成绩单截止行号1："; RowsInOnePage
                RowsInOnePage = Application.WorksheetFunction.Max(BreakRow, modelRowCount)
                'Debug.Print "首页最后一个成绩单截止行号2："; RowsInOnePage
                modelCountInOnePage = RowsInOnePage / modelRowCount
                'Debug.Print "每一页放置多少个单据："; modelCountInOnePage
            End If

            '计算调整比例
            adjustScale = FirstPageSumRowHeight / (sumModelRowHeight * modelCountInOnePage)
            Debug.Print adjustScale

            '调整
            EndRow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row

            m = 0
            For i = 1 To EndRow
                m = m + 1
                .Rows(i).RowHeight = modelRowHeight(m) * adjustScale
                If m = modelRowCount Then m = 0 '逐个单据调整
            Next i

        End If
    End With

End Sub
Sub TestAutoAdjustColumnWidthBaseOnModel()
    Set ModelSheet = ThisWorkbook.Worksheets("单据模板")
    Set PrintSheet = ThisWorkbook.Worksheets("批量打印")
    AutoAdjustColumnWidthBaseOnModel ModelSheet, PrintSheet
End Sub
Sub AutoAdjustColumnWidthBaseOnModel(ByVal ModelSheet As Worksheet, ByVal PrintSheet As Worksheet, Optional modelCountInOnePage As Variant)
    Dim ModelRng As Range '模板单元格
    Dim modelColumnWidth() As Double '模板列宽数据
    Dim modelColumnCount As Long '模板行数
    Dim sumModelColumnWidth As Double '模板累计列宽
    Dim adjustScale As Double '调整比例
    'Dim modelCountInOnePage As Long '一页打印几个单据模板
    Dim BreakColumn As Long '垂直分页符位置
    Dim FirstPageSumColumnWidth As Double '累计首页列宽
    Dim ColumnsInOnePage  As Long  '每页打印多少行
    Dim i As Long, m As Long '行号

    With ModelSheet
        'If Application.WorksheetFunction.Count(.Cells) > 0 Then
            '计数防止计算行号发生错误
            EndRow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row + 1
            EndCol = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByColumns, xlPrevious).Column
            '获取单据模板单元格区域
            Set ModelRng = .Range(.Cells(1, 1), .Cells(EndRow, EndCol))
            Debug.Print ModelRng.Address
            '获取模板单元格行数和累计列宽
            modelColumnCount = ModelRng.Columns.Count
            ReDim modelColumnWidth(1 To modelColumnCount)
            sumModelColumnWidth = 0
            For i = 1 To modelColumnCount
                modelColumnWidth(i) = ModelRng.Columns(i).ColumnWidth
                sumModelColumnWidth = sumModelColumnWidth + ModelRng.Columns(i).ColumnWidth
            Next i
            Debug.Print sumModelColumnWidth
            '记录列宽
        'End If
    End With
    '

    With PrintSheet
        Debug.Print "垂直分页符个数："; .VPageBreaks.Count
        '先判断是否有垂直分页符，如果没有则退出
        If .VPageBreaks.Count > 0 Then
            '获取第一页与第二页分页符所在的单元格
            BreakColumn = .VPageBreaks(1).Location.Column
            Debug.Print "首页分页符所在的行号："; BreakColumn
            '累计第一页所有行的高度
            i = 1
            Do While i < BreakColumn
                FirstPageSumColumnWidth = FirstPageSumColumnWidth + .Columns(i).ColumnWidth
                i = i + 1
            Loop

            'Stop

            Debug.Print FirstPageSumColumnWidth
            '获取第一页最后一个成绩单末尾的空白行行号
            If IsMissing(modelCountInOnePage) Then
                ColumnsInOnePage = BreakColumn
                Do While Application.WorksheetFunction.Count(.Columns(ColumnsInOnePage)) > 0
                    ColumnsInOnePage = ColumnsInOnePage - 1
                Loop
                Debug.Print "首页最后一个成绩单截止行号1："; ColumnsInOnePage
                ColumnsInOnePage = Application.WorksheetFunction.Max(BreakColumn, modelColumnCount)
                Debug.Print "首页最后一个成绩单截止行号2："; ColumnsInOnePage
                modelCountInOnePage = ColumnsInOnePage / modelColumnCount
                Debug.Print "每一页放置多少个单据："; modelCountInOnePage
            End If

            '计算调整比例
            adjustScale = FirstPageSumColumnWidth / (sumModelColumnWidth * modelCountInOnePage)
            Debug.Print adjustScale

            '调整
            EndCol = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByColumns, xlPrevious).Column

            m = 0
            For i = 1 To EndCol
                m = m + 1
                .Columns(i).ColumnWidth = modelColumnWidth(m) * adjustScale
                If m = modelColumnCount Then m = 0 '逐个单据调整
            Next i

        End If
    End With

End Sub