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. Delphi XE5 for Android (十)

    我觉得Delphi最强大的的功能之一就是开发数据库三层应用的DataSnap,在Android上的实现,首先是完成服务器的设计: (1)利用向导完成DataSnap服务器的框架,如下图: 由于是实验, ...

  2. UFS和EMMC的区别--原理学习【转】

    本文转载自:https://blog.csdn.net/shenjin_s/article/details/79761425 UFS PK EMMC UFS作为目前安卓智能手机最先进的非易失存储器(N ...

  3. UML(统一建模语言)是通用的可视化标准建模语言。由构造块、公共机制、构架三部分组成。

    UML UML(统一建模语言)是通用的可视化标准建模语言.由构造块.公共机制.构架三部分组成. 1.构造块:包括基本的UML建模元素(类.接口.用例等).关系(关联关系.依赖关系.泛化关系.实现关系) ...

  4. 网络存储结构简明分析—DAS、NAS和SAN 三者区别

    存储的总体分类     主流存储结构   网络存储结构大致分为三种:直连式存储(DAS:Direct Attached Storage).存储区域网络(SAN:Storage Area Network ...

  5. linux下如何删除行首的数字?

    举例如下: 1.某文件jello.txt中有以下行 1111-yes 2222-no 3333-yes-no-no 2.删除jello.txt中每行行首的数字 cat jello.txt | cut ...

  6. 三星固态sm863,pm863,sm865,sm865a颗粒

    目录 左pm863,右sm863: sm865: sm865a: 主控,缓存: 颗粒: 左pm863,右sm863: sm865: sm865a: 主控,缓存: 颗粒:

  7. SSM到Spring Boot从零开发校园商铺平台

    项目目的 特别 由于准备春招,所以希望各位看客方便的话,能去github上面帮我Star一下项目 https://github.com/Draymonders/Campus-Shop emmm, 已经 ...

  8. postgresql change table

    --if cloumn exist SELECT EXISTS (SELECT 1 FROM information_schema.columns WHERE table_schema='ent' A ...

  9. Kibana——日志可视化工具

    Kibana 基础入门 kibana产品介绍 Kibana :是一个开源的分析和可视化平台,旨在与 Elasticsearch 合作.Kibana 提供搜索.查看和与存储在 Elasticsearch ...

  10. Leetcode66-Plus One-Eassy

    Given a non-empty array of digits representing a non-negative integer, plus one to the integer. The ...