Excel VBA能不能实现排序加复制到新的工作簿

如一个学生的成绩表，总分排序一次把排名的学生姓名和排名复制到一个新的表里，语文科再排名一次再复制到新的表里，各个科目都这样操作一次

  1. 在Excel中建立如下的成绩表：

img

  1. 打开“开发工具”的VBA，插入模块，输入如下代码：
Sub SortAndCopy()
    Dim wb As Workbook
    Dim wsSrc As Worksheet
    Dim wsDst As Worksheet
    Dim rngSrc As Range
    Dim rngDst As Range
    Dim i As Long
    
    '打开当前工作簿
    Set wb = ThisWorkbook
    
    '选择源工作表
    Set wsSrc = wb.Sheets("成绩表")
    
    '选择源数据范围
    Set rngSrc = wsSrc.Range("A1").CurrentRegion
    
    '按总分排序
    rngSrc.Sort Key1:=rngSrc.Range("C2"), Order1:=xlDescending, Header:=xlYes
    
    '创建新工作簿
    Set wsDst = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
    wsDst.Name = "总分排名"
    
    '复制排名数据到新工作表
    Set rngDst = wsDst.Range("A1")
    rngSrc.Copy rngDst
    
    '添加排名列
    wsDst.Columns("D:D").Insert Shift:=xlToRight
    wsDst.Range("D1").Value = "排名"
    wsDst.Range("D2").FormulaR1C1 = "=RANK(RC[-1],R2C3:R" & rngSrc.Rows.Count + 1 & "C3)"
    wsDst.Range("D2").AutoFill Destination:=wsDst.Range("D2:D" & rngSrc.Rows.Count + 1)
    
    
     '按语文科目排序
    rngSrc.Sort Key1:=rngSrc.Range("D2"), Order1:=xlDescending, Header:=xlYes
    
    '创建新工作簿
    Set wsDst = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
    wsDst.Name = "语文排名"
    
    '复制排名数据到新工作表
    Set rngDst = wsDst.Range("A1")
    rngSrc.Copy rngDst
    
    '添加排名列
    wsDst.Columns("E:E").Insert Shift:=xlToRight
    wsDst.Range("E1").Value = "排名"
    wsDst.Range("E2").FormulaR1C1 = "=RANK(RC[-1],R2C4:R" & rngSrc.Rows.Count + 1 & "C4)"
    wsDst.Range("E2").AutoFill Destination:=wsDst.Range("E2:E" & rngSrc.Rows.Count + 1)
    
    '清除源数据排序
    rngSrc.Sort Key1:=rngSrc.Range("A1"), Order1:=xlAscending, Header:=xlYes
    
    '选择第一个工作表
    wb.Sheets(1).Activate
    
    '其他排名同上
End Sub

3.实现的结果如下：

img

img