将一个工作表根据条件拆分成多个工作表保证行列宽

熊文来

everbest2015 发表于 2019-8-15 14:12
没用你的文件  用自己的文件重写了一个。前提是没有多行表头。没有合并单元格,经测试一万行数据用时5秒

大师，有空帮我看一个文件吗？

熊文来

大六九 发表于 2019-11-23 04:39
Sub lkyy()
Set d = CreateObject("Scripting.Dictionary")
mrow = Cells(Rows.Count, 1).End(xlUp).Row
...

确实没明白。明天有分了，给你送分啊。

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, i&, dic As Object, vKey, Rng As Range, strFileName$, strPath$

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set dic = CreateObject("Scripting.Dictionary")
    ar = [A1].CurrentRegion
    Set Rng = Range("A2:A3").Resize(, UBound(ar, 2))
   
    For i = 4 To UBound(ar)
        If Not dic.exists(ar(i, 3)) Then
            Set dic(ar(i, 3)) = Rng
        End If
        Set dic(ar(i, 3)) = Union(dic(ar(i, 3)), Cells(i, 1).Resize(, UBound(ar, 2)))
    Next
   
    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
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Beep
End Sub

gwjkkkkk

销魂白米饭 发表于 2020-8-20 12:12
按照老师的方法，怎另存为工作簿呢

参与一下。。。

熊文来

gwjkkkkk 发表于 2023-3-20 19:08
参与一下。。。

还没下载文件，感觉就很好。

everbest2015

熊文来 发表于 2023-3-20 16:22
大师，有空帮我看一个文件吗？

不敢当  你说