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