Sub 導(dǎo)入成績(jī)()Const TargetSheet = "年級(jí)_原始成績(jī)匯總"Const DesSheet = "年級(jí)_本次成績(jī)總表"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")'讀取外部文件的成績(jī)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'更新內(nèi)部Set Wb = Application.ThisWorkbookFor Each Sht In Wb.WorksheetsIf Sht.Name Like "單科成績(jī)_*" 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'輸出每人每科成績(jī)，缺考的成績(jī)?yōu)榭誗et 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'復(fù)制成績(jī) 去除公式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'插入缺考標(biāo)志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 = "請(qǐng)選擇你需要的文件".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

　　

轉(zhuǎn)載于:https://www.cnblogs.com/nextseven/p/9784105.html

總結(jié)

以上是生活随笔為你收集整理的20181013xlVba导入成绩的全部?jī)?nèi)容，希望文章能夠幫你解決所遇到的問(wèn)題。

如果覺(jué)得生活随笔網(wǎng)站內(nèi)容還不錯(cuò)，歡迎將生活随笔推薦給好友。