20171104xlVBA制作联合成绩条
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
20171104xlVBA制作联合成绩条的更多相关文章
- 20181013xlVba据成绩条生成图片文件
Sub CreateGoalPictures() '声明变量 Dim Wb As Workbook Dim Sht As Worksheet Dim Shp As Shape Dim Pic, End ...
- CSS3制作同心圆进度条
1.css代码 此处在制作进度条时,是旋转进度条的半圆(红色),背景使用灰白(如果使用红色作为背景,旋转灰白遮罩,在浏览器中可能会有渲染bug) .wrapper{ display:block;pos ...
- JS-纯js制作动态成绩表(流程控制语句+js内置对象)
流程控制for循环+if判断+Math对象+Array对象+Date对象制作成绩表 <!DOCTYPE html><html> <head> <meta ch ...
- iOS 开发技巧-制作环形进度条
有几篇博客写到了怎么实现环形进度条,大多是使用Core Graph来实现,实现比较麻烦且效率略低,只是一个小小的进度条而已,我们当然是用最简单而且效率高的方式来实现. 先看一下这篇博客,博客地址:ht ...
- CSS制作环形进度条
参考来源 <Radial progress indicator using CSS>,该文核心是用纯CSS来做一个环形的进度条.纯css的意思就是连百分比这种数字,都是css生成的.文章作 ...
- unity制作简单血条
学习Unity已经10天了,也没发现有什么长进,真的急.昨天仿着官方Demo做了个射击游戏轮廓,其中需要给每个怪做一个血条. 搜了一些,挺复杂的,用NGUI或者UGUI,外加很长的代码...不过还是找 ...
- 移动端纯CSS3制作圆形进度条所遇到的问题
近日在开发的页面中,需要制作一个动态的圆形进度条,首先想到的是利用两个矩形,宽等于直径的一半,高等于直径,两个矩形利用浮动贴在一起,设置overflow:hidden属性,作为盒子,内部有一个与其宽高 ...
- 浅谈一下关于使用css3来制作圆环进度条
最近PC端项目要做一个这样的页面出来,其他的都很简单,关键在于百分比的圆环效果.我最初打算是直接使用canvas来实现的,因为canvas实现一个圆是很简便的. 下面贴出canvas实现圆环的代码,有 ...
- 用jquery制作加载条
<!DOCTYPE html> <html> <head> <meta charset="utf-8"> <title> ...
随机推荐
- 【python51--__name__属性】
一.基础知识 1.__name__ == '__main__' 所有模块都有一个__name__属性,__name__的值取决于如何应用模块,在作为独立程序运行的时候,__name__属性的值是‘__ ...
- 同时import两个版本的QtQuick【1、2】,默认使用
在同一个qml文件中,如果同时import了Qtquick1和2,那么谁在后面,谁起作用
- Python3基础 list in/not in 判断一个变量是否在列表中存在
Python : 3.7.0 OS : Ubuntu 18.04.1 LTS IDE : PyCharm 2018.2.4 Conda ...
- 那些离不开的 Chrome 扩展插件
虽然Chrome浏览器是个吃内存的怪兽,但是,它却因为启动速度.调试功能等成为了程序猿的必备浏览器!今天有时间,整理一下自己最常用的一些Chrome扩展吧: 常用网页浏览非开发类扩展: Tamperm ...
- upc组队赛1 黑暗意志【stl-map】
黑暗意志 题目描述 在数千年前潘达利亚从卡利姆多分离之时,迷雾笼罩着这块新形成的大陆,使它不被外来者发现.迷雾同样遮蔽着这片大陆古老邪恶的要塞--雷神的雷电王座.在雷神统治时期,他的要塞就是雷电之王力 ...
- P2860 [USACO06JAN]冗余路径Redundant Paths tarjan
题目链接 https://www.luogu.org/problemnew/show/P2860 思路 缩点,之后就成了个树一般的东西了 然后(叶子节点+1)/2就是答案,好像贪心的样子,lmc好像讲 ...
- FileAttributes Enum
https://docs.microsoft.com/en-us/dotnet/api/system.io.fileattributes?view=netframework-4.7.2 读取FileA ...
- 160CrackMe练手 002
首先查壳无壳,输入伪码报错,根据报错od查找字符串,定位到错误代码附近,可以看到有个条件跳转,改掉就可以爆破,接下来分析下注册算法,我们周围看看,从最近几个call看,并没有我们输入的用户名在堆栈中出 ...
- POJ 2409 Let it Bead
思路 同这道题,只是颜色数从3变成c 代码 #include <cstdio> #include <algorithm> #include <cstring> #d ...
- Ubuntu14.04下 升级 cmake
参考: How to install cmake 3.2 on ubuntu 14.04? Ubuntu14.04下升级cmake 1.通过PPA安装: $ sudo apt-get install ...