按学校、年级、班级导出相关数据

TAYM

limonet 发表于 2024-7-1 11:05
关键字：distinct+into

谢谢！请问能不能保留原格式导出

wang-way

按原格式

1. Public Sub 字典保存单元格区域保留格式的拆分()
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim nwb As Workbook
   
5.     Dim dic As Object
   
6.     Set dic = CreateObject("Scripting.Dictionary")
   
7.     Dim wb As Workbook, sht As Worksheet
   
8.     Set wb = Application.ThisWorkbook
   
9.     Set sht = wb.Worksheets("成绩")
   
10.     With sht
    
11.         eRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    
12.         Set Rng = .Range("A1").CurrentRegion
    
13.         arr = Rng.Value
    
14.         For i = 2 To UBound(arr)
    
15.             Key = arr(i, 4) & "-" & arr(i, 5) & "-" & arr(i, 6)
    
16.             If Not dic.Exists(Key) Then
    
17.               Set dic(Key) = Rng.Rows(1)
    
18.             Else
    
19.               Set dic(Key) = Union(dic(Key), Rng.Rows(i))
    
20.             End If
    
21.         Next i
    
22.     End With
    
23.     fd = wb.Path & ""
    
24.     For Each k In dic
    
25.         fp = fd & k & ".xlsx"
    
26.        Set nwb = Workbooks.Add
    
27.         nwb.SaveAs fp
    
28.         dic(k).Copy nwb.Worksheets(1).Range("a1")
    
29.         nwb.Save
    
30.         nwb.Close
    
31.     Next k
    
32.     Application.ScreenUpdating = True
    
33.     Application.DisplayAlerts = True
    
34. End Sub
    

复制代码

Qs18

Sub qs() '2024/7/1
Application.ScreenUpdating = False: Application.DisplayAlerts = False
Dim wb As Workbook, sht As Worksheet, xwb As Workbook
Set wb = ThisWorkbook: Set sht = wb.Sheets("成绩")
Set dic = CreateObject("scripting.dictionary")
    With sht.Range("a1").CurrentRegion
    arr = .Value
    For i = 2 To UBound(arr)
        s = arr(i, 4) & arr(i, 5) & "年假" & arr(i, 6) & "班"
        If Not dic.exists(s) Then
            dic(s) = Array(arr(i, 4), arr(i, 5), arr(i, 6))
        End If
    Next
  For Each k In dic.keys
        .AutoFilter
        .AutoFilter Field:=4, Criteria1:=dic(k)(0)
        .AutoFilter Field:=5, Criteria1:=dic(k)(1)
        .AutoFilter Field:=6, Criteria1:=dic(k)(2)
         Set xwb = Workbooks.Add
    .Copy xwb.Sheets(1).Range("a1")
    xwb.SaveAs ThisWorkbook.Path & "\" & k & ".xlsx"
    xwb.Close
Next
.AutoFilter
End With
Application.ScreenUpdating = True: Application.DisplayAlerts = True
Set wb = Nothing: Set xwb = Nothing: Set dic = Nothing: Set sht = Nothing
MsgBox "拆分完成"
End Sub

Qs18

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

Qs18

试一下...........

MHanys

Sub SplitIntoWorkbooks2()
Dim i As Long, j As Long, var, Fws As Worksheet
Dim dic As Object
With Application
    .ScreenUpdating = False '取消屏幕刷新
    .DisplayAlerts = False '取消警告信息
    .EnableEvents = False '取消事件响应
    .EnableCancelKey = xlDisabled '禁用取消键捕获功能
    .Calculation = xlCalculationManual '取消公式自动重算
    .AskToUpdateLinks = False '取消外链询问
End With
With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show Then strpath = .SelectedItems(1) Else Exit Sub
End With
Call killfile
Set dic = CreateObject("scripting.dictionary")
Set Fws = ActiveSheet
var = Fws.[a1].CurrentRegion
For i = 2 To UBound(var, 1)
    If Not dic.exists(var(i, 4) & "_" & var(i, 5) & "_" & var(i, 6)) Then
        Set dic(var(i, 4) & "_" & var(i, 5) & "_" & var(i, 6)) = Union(Fws.Cells(i, 1), Fws.[a1])
    Else
        Set dic(var(i, 4) & "_" & var(i, 5) & "_" & var(i, 6)) = Union(Fws.Cells(i, 1), dic(var(i, 4) & "_" & var(i, 5) & "_" & var(i, 6)))
    End If
Next i
For i = 1 To dic.Count
    Fws.Copy
    ActiveSheet.Cells.Clear
    dic.items()(i - 1).EntireRow.Copy ActiveSheet.[a1]
    With ActiveWorkbook
        .ActiveSheet.Name = dic.keys()(i - 1)
        .ActiveSheet.Rows.AutoFit
        .ActiveSheet.Columns.AutoFit
        .SaveAs strpath & "\" & dic.keys()(i - 1) & ".xlsx"
        .Close True
    End With
Next i
With Application
    .ScreenUpdating = True '恢复屏幕刷新
    .DisplayAlerts = True '恢复警告信息
    .EnableEvents = True '恢复事件响应
    .EnableCancelKey = xlInterrupt '恢复取消键捕获功能
    .Calculation = xlCalculationAutomatic '恢复公式自动重算
    .AskToUpdateLinks = True '恢复外链询问
End With
End Sub

Sub killfile()
Dim fso As Object, file As Object
Set fso = CreateObject("scripting.FileSystemObject")
On Error Resume Next
For Each file In fso.GetFolder(strpath).Files
    file.Delete (True)
Next file
End Sub

MHanys

~~~~~~~~~~~~~~~~~~~~

心的启点

练练手，重新修改了一下，测试后反馈！
成绩.rar (166.16 KB, 下载次数: 20)

2024-7-1 15:16 上传

点击文件名下载附件

lgh978

收藏下

TAYM

感谢大家的帮助！问题已解决，祝大家夏安！