求助

fushuwei

请各位大神用VBA代码的主要功能是从一个Excel工作簿的“数据表”中读取数据，根据班级进行分组，然后将每组数据填充到一个基于“反馈表”工作表的新工作簿中，并保存为以班级名称命名的Excel文件，最终实现反馈表的批量导出。一个班级一张表格，名字按照序号填充

清风竹-

请看附件。

Qs18

1. Sub qs()
   
2. Application.ScreenUpdating = False: Application.DisplayAlerts = False
   
3. Dim arr, i, xb As Workbook, p, sht As Worksheet
   
4. Set dic = CreateObject("scripting.dictionary")
   
5. p = ThisWorkbook.Path & ""
   
6. Set xb = Workbooks.Open(p & "数据表.xlsx", 0)
   
7. arr = xb.Sheets(1).Range("a1").CurrentRegion.Value
   
8. xb.Close (0)
   
9. For i = 2 To UBound(arr)
   
10.     s = arr(i, 1)
    
11.     If Not dic.exists(s) Then
    
12.         dic(s) = arr(i, 2)
    
13.     Else
    
14.         dic(s) = dic(s) & "|" & arr(i, 2)
    
15.     End If 'dic
    
16. Next
    
17. Set sht = Sheet1
    
18. brr = sht.Range("a4:f25")
    
19. With sht
    
20.    t = "班级：一年级一一班        班主任：        2024.10.1-2024.10.31"
    
21. For Each k In dic.keys
    
22. 
    
23.     cl = 2: m = 0
    
24.         .[a2].Value = VBA.Replace(t, "一年级一一班 ", k)
    
25.         ii = Split(dic(k), "|")
    
26.         For c = 2 To 6 Step 2
    
27.          For r = 1 To 22
    
28.                 If m <= UBound(ii) Then
    
29.                 brr(r, c) = ii(m)
    
30.                 m = m + 1
    
31.                 Else
    
32.                 brr(r, c) = ""
    
33.                 End If
    
34.             Next r
    
35.         Next c
    
36. 
    
37.     .Range("a4").Resize(UBound(brr), UBound(brr, 2)) = brr
    
38.     sht.Copy
    
39.     Set xb = ActiveWorkbook
    
40.     xb.SaveAs p & k
    
41.     xb.Close
    
42. Next k
    
43. End With
    
44. Set wb = Nothing: Set dic = Nothing
    
45. Application.ScreenUpdating = True: Application.DisplayAlerts = True
    
46. End Sub
    

复制代码

Qs18

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

fushuwei

谢谢二楼大大

Qs18

试试........

fushuwei

谢谢各位老大的帮助

quqiyuan

参与一下，仅供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Application.ScreenUpdating = False
    Dim wb As Workbook, sht As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("反馈表")
    arr = sht.[a1].CurrentRegion
    f = wb.Path & "\数据表.xlsx"
    With Workbooks.Open(f, 0).Sheets("数据表")
        brr = .UsedRange
        .Parent.Close 0
    End With
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(brr)
        s = brr(i, 1)
        ss = brr(i, 2)
        y = Replace(Replace(brr(i, 3), "年", "."), "月", ".")
        If InStr(arr(2, 1), y) Then
            If Not d.exists(s) Then Set d(s) = CreateObject("scripting.dictionary")
            d(s)(ss) = ""
        End If
    Next
    ReDim crr(1 To 22, 1 To 6)
    For Each k In d.keys
        n = 0
        For Each kk In d(k).keys
            n = n + 1
            If n <= 22 Then
                crr(n, 1) = n
                crr(n, 2) = kk
            ElseIf n <= 44 Then
                crr(n - 22, 3) = n
                crr(n - 22, 4) = kk
            Else
                crr(n - 44, 5) = n
                crr(n - 44, 6) = kk
            End If
        Next
        sht.Copy
        With ActiveWorkbook
            .SaveAs wb.Path & "\" & k
            .Sheets("反馈表").[a4:f25] = crr
            .Sheets("反馈表").[a2] = Replace(arr(2, 1), "一年级一一班", k)
            .Close 1
        End With
    Next
    Set d = Nothing
    Beep
    Application.ScreenUpdating = True
End Sub

yanglinzi

请测试。。