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 SubFunction 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 WithEnd Function