如何实现按条件筛选后复制到对应表中

annnie安妮

希望用VBA实现 按科目筛选出校次小于1000名词的数据复制到相对应的表单中

annnie安妮

如果按科目条件筛选出来的是空白的，那么所对应的科目表单里面的内容也要是空白

3190496160

Sub 筛选拆分()
Application.ScreenUpdating = False
Dim ar As Variant
Dim br()
Application.DisplayAlerts = False
For Each sht In Worksheets
    If sht.Index > 1 Then
        sht.Delete
    End If
Next sht
Application.DisplayAlerts = True
With Sheets("原始成绩")
    r = .Cells(Rows.Count, 2).End(xlUp).Row
   y = .Cells(1, Columns.Count).End(xlToLeft).Column
    ar = .Range(.Cells(1, 1), .Cells(r, y))
End With
For j = 5 To UBound(ar, 2) Step 2
    n = 0
    ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
    n = 1
    For s = 1 To UBound(ar, 2)
        br(n, s) = ar(1, s)
    Next s
    If Trim(ar(1, j + 1)) <> "" Then
        For i = 1 To UBound(ar)
            If Trim(ar(i, j + 1)) <> "" Then
                If ar(i, j + 1) <= 1000 Then
                    n = n + 1
                    For s = 1 To UBound(ar, 2)
                        br(n, s) = ar(i, s)
                    Next s
                End If
            End If
        Next i
    End If
    If n > 1 Then
        Set sh = Worksheets.Add(after:=Sheets(Sheets.Count))
        sh.Name = ar(1, j)
        sh.[a1].Resize(n, UBound(br, 2)) = br
        sh.[a1].Resize(n, UBound(br, 2)).Borders.LineStyle = 1
        sh.Columns("a:iv").AutoFit
    End If
Next j
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

没有模拟结果，不知道结果要如何呈现，代码仅供参考
测试.rar (27.71 KB, 下载次数: 10)

2022-12-3 20:25 上传

点击文件名下载附件

annnie安妮

3190496160 发表于 2022-12-3 20:25
没有模拟结果，不知道结果要如何呈现，代码仅供参考

谢谢大佬！基本功能已经能够实现了
但是我想把其他内有成绩的科目表单保留在那里，方便做成模板做透视表。现在的情况是如果没有那一科的成绩，那个科目的表单就没有了