Sub 导入成绩()Const TargetSheet = "年级_原始成绩汇总"Const DesSheet = "年级_本次成绩总表"Application.ScreenUpdating = FalseApplication.DisplayAlerts = FalseDim Wb As Workbook, Sht As WorksheetDim OpenWb As Workbook, OpenSht As WorksheetDim FilePath, FilePaths, SheetNameDim dGoal As ObjectDim EndRow As Long, EndCol As LongDim Arr As VariantDim Id As String, Sbj As String, Key As StringConst START_COLUMN As Long = 3Const START_ROW As Long = 1Set dGoal = CreateObject("Scripting.Dictionary")'读取外部文件的成绩FilePaths = PickFilesArr("*.xls*")If FilePaths(1) <> "NULL" ThenFor Each FilePath In FilePaths'Debug.Print FilePathSet OpenWb = Application.Workbooks.Open(FilePath)Set OpenSht = OpenWb.Worksheets(1)With OpenShtEndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).RowEndCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).ColumnSet Rng = .Range(.Cells(START_ROW, 1), .Cells(EndRow, EndCol))Arr = Rng.ValueFor 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 & ";" & SbjdGoal(Key) = Arr(i, j)'Debug.Print Key; " "; Arr(i, j)Next jNext iEnd WithOpenWb.CloseNext FilePathElseMsgBox "未选中任何文件!", vbInformation, "Information"End If'更新内部Set Wb = Application.ThisWorkbookFor Each Sht In Wb.WorksheetsIf Sht.Name Like "单科成绩_*" ThenWith ShtEndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).RowEndCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).ColumnSet Rng = .Range(.Cells(START_ROW, 1), .Cells(EndRow, EndCol))Arr = Rng.ValueFor 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 & ";" & SbjIf dGoal.exists(Key) Then Arr(i, j) = dGoal(Key)Next jNext iRng.Value = ArrEnd WithEnd IfNext Sht'输出每人每科成绩，缺考的成绩为空Set Sht = Wb.Worksheets(TargetSheet)With Sht.UsedRange.Offset(1, 3).ClearContentsEndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).RowEndCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).ColumnFor i = START_ROW + 1 To EndRowId = .Cells(i, 1).TextFor j = START_COLUMN + 1 To EndColSbj = .Cells(1, j).TextKey = Id & ";" & SbjIf dGoal.exists(Key) Then.Cells(i, j).Value = dGoal(Key)Else.Cells(i, j).Value = ""End IfNext jNext i'插入排名公式For j = START_COLUMN + 1 To EndColIf .Cells(1, j).Value Like "*排" ThenSet 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 = "总分" ThenSet 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 IfNext jEndRow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).RowEndRow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).RowSet Rng = .Range(.Cells(1, 1), .Cells(EndRow, EndCol))Arr = Rng.ValueEnd With'复制成绩 去除公式Set oSht = Wb.Worksheets(DesSheet)With oSht.Cells.ClearContentsSet Rng = .Range(.Cells(1, 1), .Cells(EndRow, EndCol))Rng.Value = ArrSetBorders .UsedRangeSetCenters .UsedRange.UsedRange.Columns.AutoFit'插入缺考标志EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).RowFor i = 2 To EndRow.Range("X1").Value = "是否缺考"If Application.WorksheetFunction.CountA(.Cells(i, 4).Resize(1, 20)) < 20 Then.Cells(i, "X").Value = "缺考"End IfNext iConst STUDENTS = "".Range("Y1").Value = "考生类别"For i = 2 To EndRowIf InStr(STUDENTS, .Cells(i, 2).Value) > 0 Then.Cells(i, "Y").Value = "其他"End IfNext iEnd WithSet Sht = NothingSet oSht = NothingSet Rng = NothingSet dGoal = NothingApplication.ScreenUpdating = TrueApplication.DisplayAlerts = TrueEnd Sub
Function PickFilesArr(Optional FileTypeFilter As String = "", Optional FileNameContain As String = "*", Optional FileNameNotContain As String = "") As String()Dim FilePath As StringDim Arr() As StringReDim Arr(1 To 1)Dim FileCount As LongDim i As LongFileCount = 0With Application.FileDialog(msoFileDialogFilePicker).AllowMultiSelect = True.InitialFileName = Application.ActiveWorkbook.Path.Title = "请选择你需要的文件".Filters.ClearIf Len(FileTypeFilter) > 0 Then.Filters.Add "您需要的文件类型", FileTypeFilterEnd IfIf .Show = -1 ThenArr(1) = "NULL"For i = 1 To .SelectedItems.CountIf .SelectedItems(i) Like FileNameContain ThenIf Len(FileNameNotContain) = 0 ThenFileCount = FileCount + 1ReDim Preserve Arr(1 To FileCount)Arr(FileCount) = .SelectedItems(i)Debug.Print Arr(FileCount)ElseIf Not .SelectedItems(i) Like FileNameNotContain ThenFileCount = FileCount + 1ReDim Preserve Arr(1 To FileCount)Arr(FileCount) = .SelectedItems(i)End IfEnd IfEnd IfNext iPickFilesArr = ArrElse'MsgBox "Pick no file！"Arr(1) = "NULL"PickFilesArr = ArrExit FunctionEnd IfEnd With
End Function