按类型导出

hhxq001

怎么按助学类型导出为分表（分簿），如所有类型为高中的导为1簿、学前的导为1簿。。。。


按类型导出.rar (781.51 KB, 下载次数: 10)

2024-6-4 18:24 上传

点击文件名下载附件

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, i&, dic As Object, vKey, Rng As Range, strPath$, strFileName$
   
    DoApp False
    Set dic = CreateObject("Scripting.Dictionary")
    With [a1].CurrentRegion
        ar = .Value
        Set Rng = .Rows("1:4")
        For i = 5 To UBound(ar)
            If Not dic.exists(ar(i, 14)) Then
                Set dic(ar(i, 14)) = Rng
            End If
            Set dic(ar(i, 14)) = Union(dic(ar(i, 14)), .Rows(i))
        Next
    End With
   
    strPath = ThisWorkbook.Path & "\"
    For Each vKey In dic.keys
        strFileName = strPath & vKey
        With Workbooks.Add
            dic(vKey).Copy
            .Sheets(1).[a1].PasteSpecial xlPasteColumnWidths
             dic(vKey).Copy .Sheets(1).[a1]
            .SaveAs strFileName
            .Close
        End With
    Next
   
    Set dic = Nothing: Set Rng = Nothing
    DoApp
    Beep
End Sub
Function DoApp(Optional b As Boolean = True)
    With Application
        .ScreenUpdating = b
        .DisplayAlerts = b
        .Calculation = -b * 30 - 4135
    End With
End Function

gwjkkkkk

.............

quqiyuan

供参考

quqiyuan

刚才上面帖子有个单元格引用错误，把第五行也写进来，是错的，供参考

hhxq001

quqiyuan 发表于 2024-6-4 21:58
刚才上面帖子有个单元格引用错误，把第五行也写进来，是错的，供参考

速度有点慢呀，与公式多有关？