求大神用代码，将数据复制过去

dtang

按照原始数据里的学号，把原始数据拆分成各个班的成绩。学号第一位是年级代码，第二和三位是班级代码。拆分的新表以年级加班级命名，并把原始数据里相应的数据复制过去。

现在的代码可以完成拆分，命名，并把表头复制了，但学生信息复制不过去。请大神帮忙看看。

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, i&, dic As Object, vKey, rngData As Range, wks As Worksheet

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    With Worksheets("原始数据")
        With .[A1].CurrentRegion
            ar = .Value
            Set rngData = .Rows("1:2")
            For i = 3 To UBound(ar)
                vKey = Mid(ar(i, 1), 1, 1) & "年级" & Val(Mid(ar(i, 1), 2, 2)) & "班 "
                If Not dic.exists(vKey) Then
                    Set dic(vKey) = rngData
                End If
                Set dic(vKey) = Union(dic(vKey), .Rows(i))
            Next
        End With
        For Each wks In Worksheets
            If wks.Name <> .Name Then wks.Delete
        Next
    End With
   
    For Each vKey In dic.keys
        With Worksheets.Add(after:=Worksheets(Worksheets.Count))
            .Name = vKey
            dic(vKey).Copy
            .[A1].PasteSpecial xlPasteColumnWidths
            dic(vKey).Copy .[A1]
        End With
    Next

    Set dic = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考。。。。

lcluck2002

由于这里截取字符串获取班级号存在问题，导致classNum一直为0，所以取不到数。

dtang

gwjkkkkk 发表于 2024-12-21 17:08
请参考。。。。

谢谢大神。

dtang

lcluck2002 发表于 2024-12-21 17:10
由于这里截取字符串获取班级号存在问题，导致classNum一直为0，所以取不到数。

谢谢指点。我试试。

dtang

lcluck2002 发表于 2024-12-21 17:10
由于这里截取字符串获取班级号存在问题，导致classNum一直为0，所以取不到数。

请问大神，这个如何修改呢。谢谢。

ykcbf1100

总表拆分多表。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.12.21   总表拆分为多表
   
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.     For Each sht In Sheets
   
10.         If sht.Name <> sh.Name Then sht.Delete
    
11.     Next
    
12.     With sh
    
13.         .AutoFilterMode = False
    
14.         r = .Cells(Rows.Count, 1).End(3).Row
    
15.         c = .Cells(2, "XFD").End(1).Column
    
16.         arr = .[a1].Resize(r, c)
    
17.         For i = 3 To UBound(arr)
    
18.             s = Left(arr(i, 1), 3)
    
19.             If s <> Empty Then
    
20.                 If Not d.Exists(s) Then
    
21.                     Set d(s) = Union(.Rows("1:2"), .Rows(i))
    
22.                 Else
    
23.                     Set d(s) = Union(d(s), .Rows(i))
    
24.                 End If
    
25.             End If
    
26.         Next i
    
27.     End With
    
28.     For Each k In d.keys
    
29.         Set sht = ws.Sheets.Add(After:=ws.Sheets(ws.Sheets.Count))
    
30.         With sht
    
31.             .Name = Left(k, 1) & "年级" & Val(Mid(k, 2)) & "班"
    
32.             d(k).Copy .[a1]
    
33.             .DrawingObjects.Delete
    
34.         End With
    
35.     Next
    
36.     sh.Activate
    
37.     Set d = Nothing
    
38.     Application.DisplayAlerts = True
    
39.     Application.ScreenUpdating = True
    
40.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
41. End Sub
    
42. 
    

复制代码

jj4599

看是不是你想要的
https://club.excelhome.net/forum.php?mod=viewthread&tid=1672371&page=1&mobile=2#pid11643172