求VBA代码：将A列筛选同类的所有行，选择需要的几列数据，存指定表中分项目按序排列

hongyunhada

一、用以下几个模块加函数公式可以解决
Sub 拆分年级()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Call Sht_add
Call Fen_Lei
Call TEST
Call 复制函数
MsgBox "完成拆分排名!"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
’********************************
Sub Sht_add()
'根据B列不同数据为标签名，在同一簿中建立多个表格。
Dim i As Integer, Sht As Worksheet
     i = 2                                               '第一条记录的行号为3,根据实际表格设置更正
       Set Sht = Worksheets("体质健康成绩")         '“”号中的标签名根据实际表标签名更改填写
   Do While Sht.Cells(i, "A").Value <> ""                       '定义循环B列条件——不等于空值的
       On Error Resume Next                               '当没有对应班级号工作表时，忽略下一行代码运行引起的错误
      
       If Worksheets(Sht.Cells(i, "A").Value) Is Nothing Then '判断如果不存在对应标签名的工作表，则
          Worksheets.Add after:=Worksheets(Worksheets.Count) '在所有工作表后插入新工作表。
          ActiveSheet.Name = Sht.Cells(i, "A").Value         '根据B列数据不同，依次命名不同表标签名
       End If
     i = i + 1                                            '行号增加1行查询，直到所有数据查完
   Loop
   Worksheets("体质健康成绩").Activate
End Sub

  ‘*************************************************
Sub Fen_Lei()
  '把成绩表按B列班名分到各个对应班名的工作表中
  Dim t As Long, bj As String, rng As Range, Sht As Worksheet
      t = 2
      bj = Cells(t, "A").Value
     Worksheets("体质健康成绩").Range("A1:W1").Copy Worksheets(bj).Range("A1")
  Do While bj <> ""
     Set rng = Worksheets(bj).Range("A65536").End(xlUp).Offset(1, 0) '将各分表的A列第1个空单元格赋给rng
     Cells(t, "A").Resize(1, 23).Copy rng                             '将记录复制到相应的工作表中
          t = t + 1
     bj = Cells(t, "A").Value

  Loop


End Sub

‘******************************************
Sub TEST()
'然后删除不需要的列以简化
    Dim arr, i&, j&, wks As Worksheet, rng As Range
    arr = Array(2, 4, 5, 8, 9, 10, 11, 12, 13, 14, 16, 18, 20, 22)
    For Each wks In ThisWorkbook.Sheets
       If wks.Name Like "*年级" Then
          With wks
            Set rng = Nothing
            For i = 0 To UBound(arr)
                If rng Is Nothing Then
                  Set rng = .Columns(arr(i))
                  Else
                  Set rng = Union(rng, .Columns(arr(i)))
                End If
            Next
          End With
          rng.Delete
       End If
    Next wks
    Beep
   
End Sub

’********************************

  Sub 复制函数()
    Application.ScreenUpdating = False
    Application.Calculation = xlManual  '开启手动重算（关闭自动重算）
   
    Dim rngs As Range
    With Sheets("公式表")  ’须事先定好位置写好的公式表
        Set rngs = .Range("K1").CurrentRegion   'K1所在区域
    End With
   
    Dim arr
    arr = Array("一年级", "二年级", "三年级", "四年级", "五年级", "六年级")
            
    Dim i As Integer
    For i = 0 To 5
        With Sheets(arr(i))
            rngs.Copy .Range("K1")  '粘贴公式及内容
            .Range("K1").CurrentRegion.EntireColumn.AutoFit '自动列宽
        End With
    Next
   
    Application.Calculation = xlAutomatic  '恢复自动重算

End Sub
‘************************************************
！！！！！以上代码能实现，但运行要2'多钟——————
且看大神“清风竹-”代码，秒完成！简捷妙思，不同凡响！！！！佩服得五体投地！

Sub 一键秒提前十名()
Application.ScreenUpdating = False

  m = Sheet1.Cells(65536, 4).End(3).Row
   arr = Sheet1.Range("a1:g" & m)
    arr2 = Sheet1.Range("o1:w" & m)
    ReDim brr(1 To UBound(arr) * 6, 1 To 7)
     Sheet6.Activate                      ’集中在表6中建档完成。
     Sheet6.Range("aa1:af1") = Array("年级", "性别", "姓名", "项目", "成绩", "成绩2")
    For j = 1 To 10 Step 2
         For i = 2 To UBound(arr)
           n = n + 1
            brr(n, 1) = arr(i, 1)
             brr(n, 2) = arr(i, 7)
              brr(n, 3) = arr(i, 3) & arr(i, 6)
               brr(n, 4) = arr2(1, j)
                brr(n, 5) = arr2(i, j)
               If j = 1 Then
                If arr2(i, j) = "" Then brr(n, 6) = 0 Else brr(n, 6) = 50 - arr2(i, j)
               Else
                  brr(n, 6) = arr2(i, j)
               End If
               If brr(n, 2) = "男" Then x = 0 Else x = 10
              brr(n, 7) = Mid(arr(i, 3), 1, 1) & "|" & j & "|" & x
         Next
     Next
         Sheet6.Range("aa2:ag" & n + 1) = brr
          Sheet6.Range("aa1:ag" & n + 1).Sort key1:=Range("ag2"), order1:=1, key2:= _
          Range("af2"), order2:=2, Header:=xlGuess
       brr = Sheet6.Range("aa1:ag" & n + 1)
       ReDim crr(1 To UBound(arr), 1 To 15)
        For i = 2 To UBound(brr)
          If brr(i, 7) <> brr(i - 1, 7) Then
             brr(i, 6) = 1
          Else
             If brr(i - 1, 6) < 10 Then brr(i, 6) = brr(i - 1, 6) + 1 Else brr(i, 6) = ""
          End If
         If brr(i, 6) <> "" And brr(i, 5) <> "" Then
               a = Split(brr(i, 7), "|")
               crr(a(0) * 24 - 24 + brr(i, 6) + --a(2) + 2, 2 + --a(1)) = brr(i, 3)
               crr(a(0) * 24 - 24 + brr(i, 6) + --a(2) + 2, 3 + --a(1)) = brr(i, 5)
                If brr(i, 2) & brr(i, 6) = "男1" Then
                   crr(a(0) * 24 - 24 + brr(i, 6) + --a(2) + 1, 2 + --a(1)) = "班级&姓名"
                   crr(a(0) * 24 - 24 + brr(i, 6) + --a(2) + 1, 3 + --a(1)) = "成绩"
                   crr(a(0) * 24 - 24 + brr(i, 6) + --a(2), 2 + --a(1)) = brr(i, 4)
                End If
               If --a(1) = 1 Then
                   crr(a(0) * 24 - 24 + brr(i, 6) + --a(2) + 2, 1) = brr(i, 2)
                   crr(a(0) * 24 - 24 + brr(i, 6) + --a(2) + 2, 2) = brr(i, 6)
                  If brr(i, 2) & brr(i, 6) = "男1" Then
                     crr(a(0) * 24 - 24 + brr(i, 6) + --a(2) + 1, 1) = brr(i, 1)
                     crr(a(0) * 24 - 24 + brr(i, 6) + --a(2) + 1, 2) = "排名"
                     crr(a(0) * 24 - 24 + brr(i, 6) + --a(2), 1) = "年级"
                     crr(a(0) * 24 - 24 + brr(i, 6) + --a(2), 2) = "前10名"
                  End If
               End If
         End If
       Next
     Columns("aA:AG").ClearContents
    Sheet6.Range("a1:l" & UBound(crr)) = crr
Application.ScreenUpdating = True
End Sub