如何用EXCEL的vba实现分数查询功能

发布网友

我来回答

共2个回答

热心网友

答：完全按照你的图示，我写了段程序，测试结果正确。

Sub ScoreQuery()
    Dim Orng As Range
    Dim ObjRng As Range
    Dim C As Range
    Dim FirstAddress As String
    Dim Cnt As Long
    
    Set Orng = Sheets("Sheet1").Range("A2")
    Orng.Offset(-1, 1).Resize(1, 2) = Array("科目", "成绩")
    With Sheets("Sheet2")
        Set ObjRng = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
    End With
    Do Until IsEmpty(Orng)
        Cnt = Application.CountIf(ObjRng, Orng.Value)
        If Cnt = 0 Then
            Set Orng = Orng.Offset(1, 0)
        Else
            Set C = ObjRng.Find(what:=Orng.Value, LookIn:=xlValues, lookat:=xlPart)
            FirstAddress = C.Address
            If Cnt > 1 Then
                Range(Orng.Offset(1, 0), Orng.Offset(Cnt - 1, 0)).EntireRow.Insert
                Range(Orng, Orng.Offset(Cnt - 1, 0)).EntireRow.FillDown
            End If
            Do
                Orng.Offset(0, 1) = C.Offset(0, 1)
                Orng.Offset(0, 2) = C.Offset(0, 2)
                Set Orng = Orng.Offset(1, 0)
                Set C = ObjRng.FindNext(C)
            Loop While Not C Is Nothing And C.Address <> FirstAddress
        End If
    Loop
    MsgBox "查询完毕！", vbInformation, "提示"
End Sub

热心网友

VBA可以实现。。。。。。。。。。。。