单条件拆分改为多条件拆分

hbszls

学生成绩表，原来是以班级为单一条件拆分为工作薄的，现在烦请大家帮忙改下，改为以学校+班级两个条件拆分。原代码来自于网上，谢谢！

shiruiqiang

拆分成多校多班级

limonet

关键字：into

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Arr As Variant, Brr As Variant, i%, j%
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    Arr = Application.Transpose(Application.Transpose(Cn.Execute("Select Distinct 学校 From [班级成绩(总分)$A2:I]").GetRows))
    Brr = Cn.Execute("Select 学校,班级 From [班级成绩(总分)$A2:I] Group By 学校,班级").GetRows
    CreateObject("WScript.Shell").Run "Powershell foreach ($S in ('" & Join(Arr, "','") & "')) {MD " & ThisWorkbook.Path & "\$S}", 0, True
    For i = 0 To UBound(Brr, 2)
        Cn.Close: Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 XML;Data Source=" & ThisWorkbook.Path & "\" & Brr(0, i) & "\" & Brr(1, i) & ".xlsx"
        StrSQL = "Select * Into [Sheet1] From [Excel 12.0;DataBase=" & ThisWorkbook.FullName & "].[班级成绩(总分)$A2:I] Where 学校='" & Brr(0, i) & "' And 班级=" & Brr(1, i)
        Cn.Execute (StrSQL)
    Next i
End Sub

yanglinzi

请测试。。

yanglinzi

1. Sub 按学校班级拆分()
   
2. Dim arr, brr, i, j, r, d
   
3. Set d = CreateObject("scripting.dictionary")
   
4. With Sheet5
   
5.     r = .Cells(Rows.Count, 1).End(xlUp).Row
   
6.     arr = .Range("a2:i" & r)
   
7. End With
   
8. For i = 2 To UBound(arr)
   
9.     sa = arr(i, 1)
   
10.     sb = arr(i, 2)
    
11.     If Not d.exists(sa) Then
    
12.         Set d(sa) = CreateObject("scripting.dictionary")
    
13.     End If
    
14.     d(sa)(sb) = d(sa)(sb) & "," & i
    
15. Next
    
16. For Each ka In d.keys
    
17.     For Each kb In d(ka).keys
    
18.         n = 1
    
19.         xa = Split(d(ka)(kb), ",")
    
20.         ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
21.         For i = 1 To UBound(xa)
    
22.             n = n + 1
    
23.             For j = 1 To UBound(arr, 2)
    
24.                 brr(1, j) = arr(1, j)
    
25.                 brr(n, j) = arr(xa(i), j)
    
26.             Next
    
27.         Next
    
28.         Set sh = Sheets.Add(after:=Sheets(Sheets.Count))
    
29.         sh.Name = ka & kb
    
30.         sh.[a2].Resize(n, 9) = brr
    
31.     Next
    
32. Next
    
33. End Sub
    

复制代码

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf2()   '//2024.5.4
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     p = ThisWorkbook.Path & ""
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set sh = ThisWorkbook.Sheets("班级成绩(总分)")
   
7.     arr = sh.UsedRange
   
8.     bt = 2        '//标题行数
   
9.     For i = bt + 1 To UBound(arr)
   
10.         s = arr(i, 1) & "-" & arr(i, 2)
    
11.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
12.         d(s)(i) = Application.Index(arr, i)
    
13.     Next
    
14.     For Each k In d.keys
    
15.         sh.Copy
    
16.         Set wb = ActiveWorkbook
    
17.         m = d(k).Count
    
18.         With wb.Sheets(1)
    
19.             .Name = k
    
20.             .DrawingObjects.Delete
    
21.             .UsedRange.Offset(bt + m).Clear
    
22.             .Cells(bt + 1, 1).Resize(m, UBound(arr, 2)) = Application.Rept(d(k).Items, 1)
    
23.         End With
    
24.         wb.SaveAs p & k
    
25.         wb.Close 1
    
26.     Next
    
27.     Application.ScreenUpdating = True
    
28.     MsgBox "OK！"
    
29. End Sub
    

复制代码

zhangcheng6688

yanglinzi 发表于 2024-5-4 15:29

字典的嵌套，先留个底，谢谢