请教各位老师，如何将工作簿中的多个工作表按关键字拆分成各自的工作簿

lizhipei78

学电子表格 发表于 2022-7-27 20:28
把工作簿里格式完全一样（表头）的3张表合并，然后按照经理这个关键字拆分，我测试了哈 ，拆分用时3秒多一 ...

我也觉得这样子效率更高，代码更简单

学电子表格

首先数据合并，你的表格已经算比较规范的了，你将工作簿全部合并再一张工作表上，然后再按照关键字拆分 。用到数组，字典这些。表格循环不行，数量大了，慢 。

全都是已注册

MARK一下，等会试试哪个快

ykcbf1100

代码重写，原格式拆分，拆分速度有明显提升。

ykcbf1100

1. Sub ykcbf2()   '//2025.3.19 多表拆分为多工作簿多表
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Dim tm: tm = Timer
   
6.     Set ws = ThisWorkbook
   
7.     p = ThisWorkbook.Path & ""
   
8.     On Error Resume Next
   
9.     col = 2: bt = 2
   
10.     For Each sht In ws.Sheets
    
11.         arr = sht.UsedRange
    
12.         For i = bt + 1 To UBound(arr)
    
13.             If arr(i, col) <> Empty Then d(arr(i, col)) = ""
    
14.         Next
    
15.     Next
    
16.     For Each k In d.keys
    
17.         ws.Sheets.Copy
    
18.         Set wb = ActiveWorkbook
    
19.         For Each sht In wb.Sheets
    
20.             With sht
    
21.                 If .FilterMode = True Then .ShowAllData
    
22.                 arr = .UsedRange
    
23.                 .DrawingObjects.Delete
    
24.                 .Rows(bt).AutoFilter Field:=col, Criteria1:="<>" & k
    
25.                 .UsedRange.Offset(bt).Delete
    
26.                 If .FilterMode = True Then .ShowAllData
    
27.             End With
    
28.         Next
    
29.         wb.SaveAs p & k
    
30.         wb.Close
    
31.     Next
    
32.     Application.ScreenUpdating = True
    
33.     Application.DisplayAlerts = True
    
34.     MsgBox "共用时：" & Format(Timer - tm, "0.000") & "秒！"
    
35. End Sub
    
36. 
    
37. 
    

复制代码