将一个总表按按客户名称拆为独立的表保存

Yalishanda30

ZYX817 发表于 2021-5-24 17:02
拆分的几个表合并在同一个表可以吗？

稍加修改即可

ZYX817

Yalishanda30 发表于 2021-5-24 18:59
稍加修改即可

自己微加修后增加了另两个表，变成只能分拆第一和第四个表。。能不能麻烦大神帮我写完万分感激

ZYX817

marchwen01 发表于 2021-5-21 19:17
还好，可以写出一些新意。

可以增加拆分后报表保留原报表的格式吗

fzxba

ZYX817 发表于 2023-4-25 17:18
可以增加拆分后报表保留原报表的格式吗

考古-保留格式-仅参考.rar (22.58 KB, 下载次数: 10)

2023-4-27 16:31 上传

点击文件名下载附件

ykcbf1100

参与一下。

多表拆分为多工作簿多表。

ykcbf1100

代码重写，原代码有点小问题。附件本身也有问题，表与表之间拆分字段名不一致，造成拆分后表部分数据丢失。

ykcbf1100

1. Sub ykcbf()   '//2025.3.21 多表拆分为多工作簿多表
   
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.     xm = "一键拆分"
   
9.     On Error Resume Next
   
10.     bt = 1
    
11.     For Each sht In ws.Sheets
    
12.         If sht.Name <> xm Then
    
13.             With sht
    
14.                 arr = .UsedRange
    
15.                 col = .Rows(bt).Find("单位名称").Column
    
16.             End With
    
17.             For i = bt + 1 To UBound(arr)
    
18.                 If arr(i, col) <> Empty Then d(arr(i, col)) = ""
    
19.             Next
    
20.         End If
    
21.     Next
    
22.     For Each k In d.keys
    
23.         ws.Sheets.Copy
    
24.         Set wb = ActiveWorkbook
    
25.         For Each sht In wb.Sheets
    
26.             If sht.Name <> xm Then
    
27.                 With sht
    
28.                     If .FilterMode = True Then .FilterMode = False
    
29.                     arr = .UsedRange
    
30.                     col = .Rows(bt).Find("单位名称").Column
    
31.                     .Rows(bt).AutoFilter Field:=col, Criteria1:="<>*" & k & "*"
    
32.                     .UsedRange.Offset(bt).Delete
    
33.                     .AutoFilterMode = False          '//取消筛选状态
    
34.                 End With
    
35.             End If
    
36.         Next
    
37.         wb.SaveAs p & k
    
38.         wb.Close
    
39.     Next
    
40.     Application.ScreenUpdating = True
    
41.     Application.DisplayAlerts = True
    
42.     MsgBox "共用时：" & Format(Timer - tm, "0.000") & "秒！"
    
43. End Sub
    

复制代码

wang-way