求助＿根据条件拆分工作表的问题

明远风

把工作簿中的一个工作表按班别为条件拆分成多个工作簿，并保存到指定的文件夹中。示例如下

chxw68

拆分的例子太多太多了，拿来就能用。

lsc900707

测试参考附件：

gwjkkkkk

Option Explicit

Sub TEST1()
    Dim ar, br, cr, i&, j&, dic As Object, vKey, shp As Shape
    Dim Rng As Range, strPath$, wks As Worksheet, strFileName$
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    Set Rng = [A1:O20]
    ar = Rng.Value
    For i = 6 To UBound(ar)
        dic(ar(i, 5)) = dic(ar(i, 5)) & " " & i
    Next i
   
    strPath = ThisWorkbook.Path & "\拆分后各班情况\"
    If Dir(strPath, vbDirectory) = "" Then MkDir strPath
   
    For Each vKey In dic.keys
        cr = Split(dic(vKey))
        ReDim br(1 To UBound(cr), 1 To 5)
        For i = 1 To UBound(cr)
            For j = 1 To UBound(br, 2)
                br(i, j) = ar(cr(i), j)
            Next j
        Next i
        With Workbooks.Add
            strFileName = strPath & vKey
            With Worksheets(1)
                Rng.Copy .[A1]
                .Name = vKey
                .[A3].CurrentRegion.Offset(3).Clear
                .[A6].Resize(UBound(br), UBound(br, 2)) = br
                For Each shp In .Shapes
                    shp.Delete
                Next
            End With
            For Each wks In .Worksheets
                If wks.Name Like "*Sheet*" Then wks.Delete
            Next
            .SaveAs strFileName: .Close
        End With
    Next
   
    Set dic = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

///////////////

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()    '//2024.9.13
   
2.     Dim wb, arr, sh
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     p = ThisWorkbook.Path & "\拆分后各班情况"
   
6.     Set d = CreateObject("Scripting.Dictionary")
   
7.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
8.     arr = sh.UsedRange
   
9.     bt = 5        '//标题行数
   
10.     col = 5       '//拆分列号
    
11.     For i = bt + 1 To UBound(arr)
    
12.         s = arr(i, col)
    
13.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
14.         d(s)(i) = Application.Index(arr, i)
    
15.     Next
    
16.     For Each k In d.keys
    
17.         If k <> Empty Then
    
18.             sh.Copy
    
19.             Set wb = ActiveWorkbook
    
20.             m = d(k).Count
    
21.             With wb.Sheets(1)
    
22.                 .Name = k
    
23.                 .DrawingObjects.Delete
    
24.                 .UsedRange.Offset(bt + m).Clear
    
25.                 .Cells(bt + 1, 1).Resize(m, UBound(arr, 2)) = Application.Rept(d(k).Items, 1)
    
26.             End With
    
27.             wb.SaveAs p & k
    
28.             wb.Close
    
29.         End If
    
30.     Next
    
31.     Application.ScreenUpdating = True
    
32.     MsgBox "OK！"
    
33. End Sub
    
34. 
    

复制代码

明远风

谢谢老师们！

明远风

怎样实现以文本格式保存？要不身份证号就乱了

Qs18

1. Sub qs()
   
2. Application.ScreenUpdating = False
   
3. Dim arr, i, dic, wb As Workbook, xb As Workbook, p, rng As Range
   
4. Set rng = Sheet1.Rows("1:5")
   
5. Set dic = CreateObject("scripting.dictionary")
   
6. Set wb = ThisWorkbook
   
7. p = wb.Path & "\拆分后各班情况"
   
8. rw = Sheet1.Cells(Rows.Count, "e").End(xlUp).Row
   
9. arr = Sheet1.Range("a6:e" & rw).Value
   
10.     For i = 1 To UBound(arr)
    
11.         dic(arr(i, 5)) = ""
    
12.     Next
    
13.     For Each k In dic.keys
    
14.         For i = 1 To UBound(arr)
    
15.             s = arr(i, 5)
    
16.             If k = s Then
    
17.                 Set rng = Union(rng, wb.Sheets("Sheet1").Rows(i + 5))
    
18.             End If
    
19.         Next
    
20.         Set xb = Workbooks.Add
    
21.         rng.Copy xb.Sheets(1).Range("a1")
    
22.         Application.DisplayAlerts = False
    
23.             xb.SaveAs p & k
    
24.             xb.Close
    
25.         Application.DisplayAlerts = True
    
26.     Next
    
27. Set wb = Nothing: Set xb = Nothing
    
28. Set dic = Nothing: Set rng = Nothing
    
29. Application.ScreenUpdating = True
    
30.     MsgBox "拆分表格完成！"
    
31. End Sub

复制代码