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

hongyunhada

      如何根据A列数据，将符合条件筛选出所有行，并选择需要的几列数据，拷贝到不同组别相应的表格中，然后再找出不同性别的数值，列出前10.

     如有小学全校6个年级不同班级学生测试成绩，需要：
      把一年级筛选到一年级对应表中，并分别排出一年级男（女）生语文前10位，数学前10位，英语前10位，科学前10位；
      把二年级筛选到二年级对应表中，并分别排出二年级男（女）生语文前10位，数学前10位，英语前10位，科学前10位；
       ……
      把六年级筛选到六年级对应表中，并分别排出六年级男（女）生语文前10位，数学前10位，英语前10位，科学前10位；
类似体育成绩，如图：
      恳请高手大神帮助，实现一键或几键完成！


     关键是如图3所示，如何根据左表，分门别类排名列出相应信息？函数或VBA都可，最好VBA解决！

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

582766

用数据透视会不会更加方便

3190496160

Sub 拆分()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
For Each sh In Sheets
    If sh.Index > 2 Then
        sh.Delete
    End If
Next sh
With Sheets("体质健康成绩")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:r" & r)
End With
For i = 2 To UBound(ar)
    If Trim(ar(i, 1)) <> "" Then
        d(Trim(ar(i, 1))) = ""
    End If
Next i
For Each k In d.keys
    n = 0: dc.RemoveAll
    m = 0: w = 0
    ReDim br(1 To UBound(ar), 1 To 8)
    ReDim cr(1 To UBound(ar), 1 To 8)
    ReDim arr(1 To UBound(ar), 1 To 8)
    For i = 2 To UBound(ar)
        If Trim(ar(i, 1)) = k Then
            n = n + 1
            y = 0
            m = m + 1: w = w + 1
            For j = 1 To 7
                If j <> 2 And j <> 4 And j <> 5 Then
                    y = y + 1
                    br(n, y) = ar(i, j)
                    cr(m, y) = ar(1, j)
                    arr(w, y) = ar(1, j)
                End If
            Next j
            y = 4
            For j = 10 To 16 Step 2
                y = y + 1
                br(n, y) = ar(i, j)
                cr(m, y) = ar(1, j)
                arr(w, y) = ar(1, j)
            Next j
            If Trim(ar(i, 7)) = "男" Then
                m = m + 1: y_男 = 0
                For j = 1 To 7
                    If j <> 2 And j <> 4 And j <> 5 Then
                        y_男 = y_男 + 1
                        cr(m, y_男) = ar(i, j)
                    End If
                Next j
                y = 4
                For j = 10 To 16 Step 2
                    y = y + 1
                    cr(m, y) = ar(i, j)
                Next j
            End If
            If Trim(ar(i, 7)) = "女" Then
                w = w + 1: y_女 = 0
                For j = 1 To 7
                    If j <> 2 And j <> 4 And j <> 5 Then
                        y_女 = y_女 + 1
                        arr(w, y_女) = ar(i, j)
                    End If
                Next j
                y = 4
                For j = 10 To 16 Step 2
                    y = y + 1
                    arr(w, y) = ar(i, j)
                Next j
            End If
        End If
    Next i
    Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
    With sht
        .Name = k
        p = 0
        For j = 1 To 7
            If j <> 2 And j <> 4 And j <> 5 Then
                p = p + 1
                .Cells(1, p) = ar(1, j)
            End If
        Next j
        y = 4
        For j = 10 To 16 Step 2
            y = y + 1
            .Cells(1, y) = ar(1, j)
        Next j
        .[a2].Resize(n, UBound(br, 2)) = br
        .[a1].Resize(n + 1, UBound(br, 2)).Borders.LineStyle = 1
        'For j = 5 To 8
            'If cr(1, j) = "50米跑" Or cr(1, j) = "50米跑" Then
                'zx = Application.Large(Application.Index(cr, 0, j), 10)
    End With
Next k
MsgBox "OK!"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

3190496160

体育测试分年级分性别统计前十名.rar (377.68 KB, 下载次数: 11)

2022-11-7 09:39 上传

点击文件名下载附件

3190496160

这个问题，不是一般的繁琐，目前只是完成了按年级拆分数据，提取名次等有时间再看看吧

hongyunhada

3190496160 发表于 2022-11-7 09:39

，感谢！
     希望能在完成的代码后面加上注释。因为随着年级提高，科目会增加到5项、6项，读懂了代码，在关键变量上能修改增删。
      再次感谢！

hongyunhada

3190496160 发表于 2022-11-7 09:40
这个问题，不是一般的繁琐，目前只是完成了按年级拆分数据，提取名次等有时间再看看吧

试用拆分代码，不仅慢，而且将其它原有的工作表给删除了。

3190496160

你还想飞不成

3190496160

至于删除工作表，代码只能是针对你上传的附件来写，
目前的代码仅仅是一个初稿，还有很多未考虑的因素。更还有为完成的功能

hongyunhada

3190496160 发表于 2022-11-11 13:24
至于删除工作表，代码只能是针对你上传的附件来写，
目前的代码仅仅是一个初稿，还有很多未考虑的因素。更 ...

也许是各自所用Office版本不同和计算机配置不同造成的吧！分性别分项目分别列出排名表，换一种方式尝试中：数组函数公式。
再次感谢大佬！