利用VBA在数据总表，对数据进行按条件提取到指定表格

yanqiuyun100

大家好！
我是菜鸟，非常感谢EXCELHOME陪我成长的这几年，有一这边奉献的朋友！真了不起！
我再次求助：例如有这样的一个总表格：而且在不断地更新；


我希望通过一个按钮，或者直接可以自动，按班级的条件，分别把对于行数据复制到对应的表格；
我在网上学习到以下代码：

Sub 按钮1_Click()
        Dim j As Byte
           For j = 2 To Worksheets.Count
                         Worksheets("成绩表").Range("A1:G1").Copy Destination:=Worksheets(j).Range("A1")
                Next
  
End Sub

这段是把表头按条件复制到对应表格，
但是把内容按条件增加就出现问题

skiss

拆分。。。。。供参考。

yanqiuyun100

skiss 发表于 2024-7-4 11:43
拆分。。。。。供参考。

非常感谢skiss前辈!体验非常好！谢谢你

ykcbf1100

就是一个总表按班级拆分。

附件供参考，按原格式拆分。

ykcbf1100

总表拆分为多表，原格式

1. Sub ykcbf()  '//2024.7.4
   
2.     Dim arr, brr, d
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Application.DisplayAlerts = False
   
6.     Dim tm: tm = Timer
   
7.     Set ws = ThisWorkbook
   
8.     Set sh = ws.Sheets("成绩表")
   
9.     bt = 1
   
10.     For Each sht In Sheets
    
11.         If sht.Name <> sh.Name Then sht.Delete
    
12.     Next
    
13.     arr = sh.UsedRange
    
14.     For i = bt + 1 To UBound(arr)
    
15.         s = arr(i, 3)    '//按班级拆分
    
16.         If s <> Empty Then
    
17.             If Not d.Exists(s) Then
    
18.                 Set d(s) = CreateObject("scripting.dictionary")
    
19.             End If
    
20.             d(s)(i) = Application.Index(arr, i)
    
21.         End If
    
22.     Next i
    
23.     For Each k In d.keys
    
24.         sh.Copy after:=Sheets(Sheets.Count)
    
25.         Set sht = Sheets(Sheets.Count)
    
26.         m = d(k).Count
    
27.         With sht
    
28.             .Name = k
    
29.             .UsedRange.Offset(m + bt).Clear
    
30.             .DrawingObjects.Delete
    
31.             .Cells(bt + 1, 1).Resize(m, UBound(arr, 2)) = Application.Rept(d(k).Items, 1)
    
32.         End With
    
33.     Next k
    
34.     sh.Activate
    
35.     Set d = Nothing
    
36.     Application.DisplayAlerts = True
    
37.     Application.ScreenUpdating = True
    
38.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
39. End Sub
    
40. 
    

复制代码

Qs18

Sub qs() '2024/7/4数据进行按条件复制到指定表格
Dim arr, dic, i, sht As Worksheet
arr = Sheet1.Range("a1").CurrentRegion
Set dic = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr)
    s = arr(i, 3)
    If Not dic.exists(s) Then dic(s) = ""
Next
Set sht = Sheets("成绩表")
With sht.Range("a1").CurrentRegion
For Each k In dic.keys
    .AutoFilter
    .AutoFilter Field:=3, Criteria1:=k
    .Copy Sheets(k).Range("a1")
Next
.AutoFilter
End With
End Sub

Qs18

试试............

Qs18

试试........

英子-TS

ykcbf1100 发表于 2024-7-4 15:49
就是一个总表按班级拆分。

附件供参考，按原格式拆分。

向老师学习

ykcbf1100

英子-TS 发表于 2024-7-4 16:46
向老师学习

相互学习。。。