Sub 导入成绩()

    Const TargetSheet = "年级_原始成绩汇总"
Const DesSheet = "年级_本次成绩总表" Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Wb As Workbook, Sht As Worksheet
Dim OpenWb As Workbook, OpenSht As Worksheet
Dim FilePath, FilePaths, SheetName
Dim dGoal As Object
Dim EndRow As Long, EndCol As Long
Dim Arr As Variant
Dim Id As String, Sbj As String, Key As String
Const START_COLUMN As Long = 3
Const START_ROW As Long = 1 Set dGoal = CreateObject("Scripting.Dictionary") '读取外部文件的成绩
FilePaths = PickFilesArr("*.xls*")
If FilePaths(1) <> "NULL" Then
For Each FilePath In FilePaths
'Debug.Print FilePath
Set OpenWb = Application.Workbooks.Open(FilePath)
Set OpenSht = OpenWb.Worksheets(1)
With OpenSht
EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
EndCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column
Set Rng = .Range(.Cells(START_ROW, 1), .Cells(EndRow, EndCol))
Arr = Rng.Value
For i = LBound(Arr) + START_ROW To UBound(Arr)
Id = CStr(Arr(i, 1))
For j = LBound(Arr, 2) + START_COLUMN To UBound(Arr, 2)
Sbj = CStr(Arr(1, j))
Key = Id & ";" & Sbj
dGoal(Key) = Arr(i, j)
'Debug.Print Key; " "; Arr(i, j)
Next j
Next i
End With
OpenWb.Close
Next FilePath
Else
MsgBox "未选中任何文件!", vbInformation, "Information"
End If '更新内部
Set Wb = Application.ThisWorkbook
For Each Sht In Wb.Worksheets
If Sht.Name Like "单科成绩_*" Then
With Sht
EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
EndCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column
Set Rng = .Range(.Cells(START_ROW, 1), .Cells(EndRow, EndCol))
Arr = Rng.Value
For i = LBound(Arr) + START_ROW To UBound(Arr)
Id = CStr(Arr(i, 1))
For j = LBound(Arr, 2) + START_COLUMN To UBound(Arr, 2)
Sbj = CStr(Arr(1, j))
Key = Id & ";" & Sbj
If dGoal.exists(Key) Then Arr(i, j) = dGoal(Key)
Next j
Next i
Rng.Value = Arr
End With
End If
Next Sht '输出每人每科成绩,缺考的成绩为空
Set Sht = Wb.Worksheets(TargetSheet)
With Sht
.UsedRange.Offset(1, 3).ClearContents
EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
EndCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column
For i = START_ROW + 1 To EndRow
Id = .Cells(i, 1).Text
For j = START_COLUMN + 1 To EndCol
Sbj = .Cells(1, j).Text
Key = Id & ";" & Sbj
If dGoal.exists(Key) Then
.Cells(i, j).Value = dGoal(Key)
Else
.Cells(i, j).Value = ""
End If
Next j
Next i '插入排名公式
For j = START_COLUMN + 1 To EndCol
If .Cells(1, j).Value Like "*排" Then
Set Rng = .Range(.Cells(2, j), .Cells(EndRow, j))
Rng.FormulaR1C1 = "=IF(RC[-1]<>"""",RANK(RC[-1],R2C[-1]:R" & EndRow & "C[-1]),"""")"
ElseIf .Cells(1, j).Value = "总分" Then
Set Rng = .Range(.Cells(2, j), .Cells(EndRow, j))
Rng.FormulaR1C1 = "=IF(COUNTA(RC[-18],RC[-16],RC[-14],RC[-12],RC[-10],RC[-8],RC[-6],RC[-4],RC[-2])=9,SUM(RC[-18],RC[-16],RC[-14],RC[-12],RC[-10],RC[-8],RC[-6],RC[-4],RC[-2]),"""")"
End If
Next j EndRow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row
EndRow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row
Set Rng = .Range(.Cells(1, 1), .Cells(EndRow, EndCol))
Arr = Rng.Value End With '复制成绩 去除公式 Set oSht = Wb.Worksheets(DesSheet)
With oSht
.Cells.ClearContents
Set Rng = .Range(.Cells(1, 1), .Cells(EndRow, EndCol))
Rng.Value = Arr
SetBorders .UsedRange
SetCenters .UsedRange
.UsedRange.Columns.AutoFit '插入缺考标志
EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
For i = 2 To EndRow
.Range("X1").Value = "是否缺考"
If Application.WorksheetFunction.CountA(.Cells(i, 4).Resize(1, 20)) < 20 Then
.Cells(i, "X").Value = "缺考"
End If
Next i
Const STUDENTS = ""
.Range("Y1").Value = "考生类别"
For i = 2 To EndRow
If InStr(STUDENTS, .Cells(i, 2).Value) > 0 Then
.Cells(i, "Y").Value = "其他"
End If
Next i End With Set Sht = Nothing
Set oSht = Nothing
Set Rng = Nothing
Set dGoal = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True End Sub
Function PickFilesArr(Optional FileTypeFilter As String = "", Optional FileNameContain As String = "*", Optional FileNameNotContain As String = "") As String()
Dim FilePath As String
Dim Arr() As String
ReDim Arr(1 To 1)
Dim FileCount As Long
Dim i As Long
FileCount = 0
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.InitialFileName = Application.ActiveWorkbook.Path
.Title = "请选择你需要的文件"
.Filters.Clear
If Len(FileTypeFilter) > 0 Then
.Filters.Add "您需要的文件类型", FileTypeFilter
End If
If .Show = -1 Then
Arr(1) = "NULL"
For i = 1 To .SelectedItems.Count
If .SelectedItems(i) Like FileNameContain Then
If Len(FileNameNotContain) = 0 Then
FileCount = FileCount + 1
ReDim Preserve Arr(1 To FileCount)
Arr(FileCount) = .SelectedItems(i)
Debug.Print Arr(FileCount)
Else
If Not .SelectedItems(i) Like FileNameNotContain Then
FileCount = FileCount + 1
ReDim Preserve Arr(1 To FileCount)
Arr(FileCount) = .SelectedItems(i)
End If
End If
End If
Next i
PickFilesArr = Arr
Else
'MsgBox "Pick no file!"
Arr(1) = "NULL"
PickFilesArr = Arr
Exit Function
End If
End With
End Function

  

20181013xlVba导入成绩的更多相关文章

  1. 20181013xlVba年级成绩报表

    Public Sub 高一成绩报表() Application.ScreenUpdating = False Application.DisplayAlerts = False Application ...

  2. 20181013xlVba据成绩条生成图片文件

    Sub CreateGoalPictures() '声明变量 Dim Wb As Workbook Dim Sht As Worksheet Dim Shp As Shape Dim Pic, End ...

  3. .Net之路(十三)数据库导出到EXCEL

    .NET中导出到Office文档(word,excel)有我理解的两种方法.一种是将导出的文件存放在server某个目录以下,利用response输出到浏览器地址栏,直接打开:还有直接利用javasc ...

  4. .Net路(十三)导出数据库到EXCEL

    .NET出口Office文件(word,excel)有两种方法我明白.一个存储在导出的文件中server录以下.利用response输出到浏览器地址栏,直接打开:还有直接利用javascript来导出 ...

  5. 20181013xlVba成绩报表优化

    Public Sub 成绩报表优化() Application.ScreenUpdating = False Application.DisplayAlerts = False Application ...

  6. C# Excel导入、导出【源码下载】

    本篇主要介绍C#的Excel导入.导出. 目录 1. 介绍:描述第三方类库NPOI以及Excel结构 2. Excel导入:介绍C#如何调用NPOI进行Excel导入,包含:流程图.NOPI以及C#代 ...

  7. [转]Java中导入、导出Excel

    原文地址:http://blog.csdn.net/jerehedu/article/details/45195359 一.介绍 当前B/S模式已成为应用开发的主流,而在企业办公系统中,常常有客户这样 ...

  8. java的poi技术读取和导入Excel

    项目结构: http://www.cnblogs.com/hongten/gallery/image/111987.html  用到的Excel文件: http://www.cnblogs.com/h ...

  9. 从零自学Hadoop(16):Hive数据导入导出,集群数据迁移上

    阅读目录 序 导入文件到Hive 将其他表的查询结果导入表 动态分区插入 将SQL语句的值插入到表中 模拟数据文件下载 系列索引 本文版权归mephisto和博客园共有,欢迎转载,但须保留此段声明,并 ...

随机推荐

  1. java虚拟机之垃圾回收算法

    标记-清除算法: 这是最基础的,就是之前所讲的两次标记,首先标记出所有 需要回收的对象,然后进行统一清除, 这有两缺点:一是效率低,标记和清除(开启低优先级进行回收)都是低效率的.第二是空间问题,标记 ...

  2. ngResource提交json数据如何带参数

    ngResource提交json数据如何带参数 直接使用ngResource和REST服务接口交互可以让程序显得简洁,前提是配置好跨域和OPTIONS请求的支持,与此同时,如果需要带些额外的参数,有两 ...

  3. Linux下安装Nginx服务器

    安装Nginx之前,首先要安装好编译环境gcc和g++,然后以CentOS为例安装Nginx,安装Nginx需要PRCE库.zlib库和ssl的支持,除了ssl外其他的我们都是去官网下载: Nginx ...

  4. 透过c的编程原则,来规范自己现在的一些编程习惯

    1.合理的使用注释 注释为:/*…………*/ 注释有以下几种情况: 1) 版本.版权声明. 2) 函数接口说明. 3) 重要的代码或者段落显示. 注释注意: 1) 注释是对代码的解释,不是对文档.注释 ...

  5. linux根目录下的文件夹

    http://wenku.baidu.com/link?url=PDpw0nuLm71kihyYWdGY2niJhQEsJXfu8NVbjy9RxLa-Zur3aoG4NkCFpD-GQKM_sQWN ...

  6. Java NIO 系列教程(转)

    原文中说了最重要的3个概念,Channel 通道Buffer 缓冲区Selector 选择器其中Channel对应以前的流,Buffer不是什么新东西,Selector是因为nio可以使用异步的非堵塞 ...

  7. eclipse ctrl shift t 失效的恢复方法

    Window-->Perspective-->Customize Perspective 在弹出框选择: Action Set Avaliability ---将最右边的java Navi ...

  8. cocos2dx --- 富文本的使用 RichText

    在实际工作中,有非常多地方会使用 富文本,这里仅仅介绍最简单的富文本用法: 是由cocostudio 提供的 RichText: 直接贴代码,再分析: //这里測试富文本控件 ui::RichText ...

  9. UML_01_画图工具

    一.推荐工具 1.processon 在线画图,类型丰富 www.processon.com 2.StarUML staruml.io 破解方法 StarUML 3.0.2 (Crack + Keyg ...

  10. Gradle配置IDEA正常识别JPA Metamodel Generator动态生成的代码

    我们在使用JPA动态查询构建查询条件时,为了实现安全的类型检查,常常需要引用Hibernate JPA Metamodel Generator自动为我们生成静态元模型类. 而这些类由于编译时由Hibe ...