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

熊文来

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
大师，有空帮我看一个文件吗？

不敢当  你说

ykcbf1100

总表原格式拆分为多表，筛选法总比Unoin法速度要快一些的。

我这里1000行数据，拆分时间约0.2秒

ykcbf1100

1. Sub ykcbf()   '//2025.3.22  总表原格式拆分成多工作表
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set ws = ThisWorkbook
   
6.     Dim tm: tm = Timer
   
7.     On Error Resume Next
   
8.     Set sh = ws.ActiveSheet
   
9.     If sh.FilterMode = True Then sh.ShowAllData
   
10.     For Each sht In ws.Sheets
    
11.         If InStr(sht.Name, sh.Name) = 0 Then sht.Delete
    
12.     Next
    
13.     Arr = sh.UsedRange
    
14.     bt = 3: Col = 3
    
15.     For i = bt + 1 To UBound(Arr)
    
16.         s = Arr(i, Col)
    
17.         If Len(s) Then d(s) = ""
    
18.     Next i
    
19.     For Each k In d.keys
    
20.         sh.Copy After:=Sheets(Sheets.Count)
    
21.         Set sht = Sheets(Sheets.Count)
    
22.         With sht
    
23.             .Name = k
    
24.             .DrawingObjects.Delete
    
25.             .Rows(bt).AutoFilter Field:=Col, Criteria1:="<>" & k
    
26.             .UsedRange.Offset(bt).Delete
    
27.             If .FilterMode = True Then .ShowAllData
    
28.         End With
    
29.     Next
    
30.     sh.Activate
    
31.     Application.ScreenUpdating = True
    
32.     Application.DisplayAlerts = True
    
33.     MsgBox "共用时：" & Format(Timer - tm, "0.000") & "秒！"
    
34. End Sub
    
35. 
    
36. 
    

复制代码

blackttea1

学习啦 ，谢谢