用VBA实现表格的拆分，论坛找到的不合适

fj1204

根据C列订单号拆分多个工作薄出来，保留前面5行抬头
底部求和也需要保留，名称数量不固定
行数都不固定多少的，拆除出来保存名称就按订单名称保存，希望能保留所有公式

里面有宏是论坛找到的，但是有些没有底部求和，底部求和不是固定位置的，还有点地方不会改，还望大神帮帮我这菜鸟。

于箱长

https://club.excelhome.net/thread-1646111-1-1.html
参考一下这个贴子

fj1204

  2022-11-16 10:04
https://club.excelhome.net/thread-1646111-1-1.html
ο

lsc900707

找不到，认真找了没？

3190496160

拆分问题，到我的主题里面去找找，几个拆分工具，一定有一个能解决你的问题的，下载就能用

3190496160

这个拆分工具完全可以满足你的需求，下载就能用
灵活拆分工具之四-Excel VBA程序开发-ExcelHome技术论坛 - https://club.excelhome.net/threa ... tml?_dsign=e2068853

ykcbf1100

原代码基础上改的。

lkqsmxw

kkkkkkkkkkkkkkkkkkkkkk

xiangbaoan

测试.rar (39.94 KB, 下载次数: 23)

2022-11-16 11:32 上传

点击文件名下载附件

3190496160

Sub 按订单保存为工作簿()
    tms = Timer
    Set Rng = Range("A1:U5")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    arr = Range("a1:bq" & Range("a65536").End(xlUp).Row)
    Set d = CreateObject("scripting.dictionary")
    For i = 6 To UBound(arr)
        If Trim(arr(i, 3)) <> "" Then
         If Not d.exists(arr(i, 3)) Then
                Set d(arr(i, 3)) = Cells(i, 1).Resize(1, 21)
            Else
                Set d(arr(i, 3)) = Union(d(arr(i, 3)), Cells(i, 1).Resize(1, 21))
         End If
        End If
    Next
    k = d.keys
    t = d.items
    For i = 0 To d.Count - 1
        Set wb = Workbooks.Add(xlWBATWorksheet)
        With wb.Sheets(1)
            Rng.Copy .[a1]: t(i).Copy .[a6]
            For j = 1 To UBound(arr, 2)
               .Columns(j).ColumnWidth = ThisWorkbook.ActiveSheet.Columns(j).ColumnWidth
            Next
            For m = 3 To UBound(arr)
                .Rows(m).RowHeight = 24
            Next
        End With
        wb.SaveAs Filename:=ThisWorkbook.Path & "\" & k(i), FileFormat:=51
        wb.Close
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "完毕!用时" & Format(Timer - tms, "0.00") & "秒"
End Sub