各位老师，都说总表拆分没难度，为啥我就无法实现啊，能帮帮我吗？

yksos518

表格里有论坛大大给我写的代码，但是还是有点问题，不知道哪位老师能优化一下吗？ 1，总表能添加个按钮，点击会按照楼栋自动拆分成 楼栋#号的分表 2，现在的代码是除了总表，删除所有表，我想保留总表和停暖两个表 3，生成的分表能按 总表-1#-2#-3#-停暖，这样排序 4，希望总表添加数据之后，点按钮能够把总表的数据同步更新到分表 哪位老师能够帮我实现啊，如果工作量大，可以加我QQ357995939 请老师喝奶茶，谢谢老师！

xlj310

没人弄吗？ 这个问题不难呀。  你的数据 是从第3行开始的吧？

lkqsmxw

KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK

yksos518

xlj310 发表于 2024-11-1 14:56
没人弄吗？  这个问题不难呀。  你的数据 是从第3行开始的吧？

对于小白太难了，感谢老师，这个运行出错了老师

yksos518

lkqsmxw 发表于 2024-11-1 15:23
KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK

感谢老师，我下载了去试试

yksos518

xlj310 发表于 2024-11-1 14:56
没人弄吗？  这个问题不难呀。  你的数据 是从第3行开始的吧？

这个有点问题，老师，提示这个错误

ykcbf1100

总表拆分为多表，确实属于简单的。

ykcbf1100

参与一下，字典+Union法

xlj310

报错点调试，看停在哪里。另外 我看了一下，你原来代码中，屏幕和提示开关都只是关了，没有打开
Application.ScreenUpdating = False
Application.DisplayAlerts = False
如意小镇C区业主供暖信息汇总表2024.zip (164.01 KB, 下载次数: 5)

2024-11-2 08:46 上传

点击文件名下载附件

micch

1. Sub Main()
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     '删除多余表
   
5.     For Each Sh In Sheets
   
6.         If Sh.CodeName = "Sheet1" Then
   
7.         ElseIf Sh.CodeName = "Sheet17" Then
   
8.         Else
   
9.             Sh.Delete
   
10.         End If
    
11.     Next
    
12.     '计算拆分表数量
    
13.     Dim d As Object
    
14.     Set d = CreateObject("scripting.dictionary")
    
15.     d.CompareMode = vbTextCompare
    
16.     ar = Sheet1.Range("E1", Sheet1.Range("E65536").End(3)).Value
    
17.     For i = 3 To UBound(ar)
    
18.         If Len(ar(i, 1)) > 0 Then
    
19.         If Not d.exists(ar(i, 1)) Then Set d(ar(i, 1)) = CreateObject("scripting.dictionary")
    
20.         d(ar(i, 1)).Add i, i
    
21.         End If
    
22.     Next
    
23.     '排序
    
24.     With Sheet1
    
25.         .Range("P:P").Clear
    
26.         .Range("P1").Resize(d.Count) = Application.Transpose(d.keys)
    
27.         .Range("P:P").Sort .Cells(1, "P"), xlAscending, , , , , , xlNo
    
28.         br = .Range("P1").Resize(d.Count)
    
29.         .Range("P:P").Clear
    
30.         r = .Cells(65536, 5).End(3).Row
    
31.         ar = .Range("A1:M" & r).Value
    
32.     End With
    
33.     '拆分
    
34.     For i = 1 To UBound(br)
    
35.         Set dic = d(br(i, 1) & "")
    
36.         Set Sh = Sheets.Add(Before:=Sheet17)
    
37.         Sh.Name = br(i, 1) & "#"
    
38.         Sheet1.Range("A:N").Copy Sh.Range("A1")
    
39.         For j = r To 3 Step -1
    
40.             If Not dic.exists(j) Then Sh.Rows(j).Delete
    
41.         Next
    
42.     Next
    
43.     MsgBox "完成"
    
44.     Set d = Nothing
    
45.     Application.ScreenUpdating = True
    
46.     Application.DisplayAlerts = True
    
47. End Sub

复制代码