20181013xlVba导入成绩

Posted 2021-01-12 nextseven

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