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
20181013xlVba成绩报表优化的更多相关文章
- 20181013xlVba年级成绩报表
Public Sub 高一成绩报表() Application.ScreenUpdating = False Application.DisplayAlerts = False Application ...
- 20181013xlVba年级报表拆分为班级报表
'年级报表拆分为班级报表 Public Sub CreateClassReport() Application.DisplayAlerts = False Dim Wb As Workbook Dim ...
- 16Aspx.com源码2013年10月到2013年12月详细
创建时间FROM: 创建时间TO: ExtJS合同管理信息系统源码 2013-12-13 [VS2008] 源码介绍: ExtJS合同管理信息系统源码浏览器兼容:IE,Firefox,谷歌等主 ...
- 系列：这一件月薪30K+的事，我们一起来撮合一下 3
作者:接地气的陈老师 ----------------------------------------------------------------------------------------- ...
- Gridview转发
首页 开源项目 问答 动弹 博客 翻译 资讯 专题 城市圈 [ 登录 | 注册 ] 博客专区 > Reya滴水心的博客详情 Asp.net中GridView使用详解(很全,很经典) Reya滴水 ...
- Asp.net中GridView使用详解(引)
GridView无代码分页排序GridView选中,编辑,取消,删除GridView正反双向排序GridView和下拉菜单DropDownList结合GridView和CheckBox结合鼠标移到Gr ...
- MYSQL调优
4核8G内存配置文件 explain SQL 查看SQL索引使用情况. my.cnf skip-external-locking skip-name-resolve back_log= key_buf ...
- 【转】 GridView 72般绝技
说明:准备出一个系列,所谓精髓讲C#语言要点.这个系列没有先后顺序,不过尽量做到精.可能会不断增删整理,本系列最原始出处是csdn博客,谢谢关注. C#精髓 第四讲 GridView 72般绝技 作者 ...
- GridView的详细用法
l GridView无代码分页排序 l GridView选中,编辑,取消,删除 l GridView正反双向排序 l GridView和下拉菜单DropDownList结合 l GridView和Ch ...
随机推荐
- Starting MySQL ERROR! Couldn't find MySQL server (/usr/local/mysql/bin/mysqld_safe)
centos7.5 安装mysql数据库报错 问题: [root@db04-54 scripts]# /etc/init.d/mysqld start /etc/init.d/mysqld: line ...
- django基础 -- 1. 前奏 web框架的本质
一. http协议 1.请求方法(get和post) 1.GET提交的数据会放在URL之后,也就是请求行里面,以?分割URL和传输数据,参数之间以&相连,如EditBook?name=test ...
- [HEOI2016/TJOI2016]树
[HEOI2016/TJOI2016]树 思路 做的时候也是糊里糊涂的 就是求最大值的线段树 错误 线段树写错了 #include <bits/stdc++.h> #define FOR( ...
- 160CrackMe练手 002
首先查壳无壳,输入伪码报错,根据报错od查找字符串,定位到错误代码附近,可以看到有个条件跳转,改掉就可以爆破,接下来分析下注册算法,我们周围看看,从最近几个call看,并没有我们输入的用户名在堆栈中出 ...
- s2-045漏洞批量检测工具
今天晚上看老铁们在群里就这个st2-045漏洞讨论得火热,个人不太喜欢日站,本来想直接写个批量挂马的东西,但是想想还是算了,如果你有兴趣,改改也很容易,反正不关我的事 测试图 2017-3-8更新 增 ...
- Linux/shell: Concatenate multiple lines to one line
$ cat file START Unix Linux START Solaris Aix SCO 1. Join the lines following the pattern START with ...
- Asp.net MVC 控制器ActionResult的例子
ActionResult 父类型 ViewResult View() 多重载应用 PartialViewResult PartialView() 部分试图 New EmptyResult() 空 如 ...
- P5159 WD与矩阵
思路 奇怪的结论题 考虑增量构造,题目要求每行每列都有偶数个1,奇偶性只需要增减1就能够调整了,所以最后一列一行一定能调整前面n-1阶矩阵的值,所以前面可以任选 答案是\(2^{(n-1)(m-1)} ...
- maven web项目配置log4j,及log4j参数设置
本文为博主原创,转载须注明转载地址: 1.在maven项目中引入相关的依赖: 需要依赖的jar为: <!-- 配置日志 --> <dependency> <groupId ...
- Git、GitHub、GitLab三者之间的联系以及区别
在讲区别以及联系之前先简要的介绍一下,这三者都是什么(本篇文章适合刚入门的新手,大佬请出门左转) 1.什么是 Git? Git 是一个版本控制系统. 版本控制是一种用于记录一个或多个文件内容变化,方便 ...