Execl拆分工具

BigCong

最近看到公司同事使用Execl自带的分拆工具拆分文件，居然要八块一个月！还不好用。
于是本着自己动手丰衣足食的原则弄了个拆分程序


使用教程如下：
1.选择文件里面选择要拆分的文件
2.加载需要拆分的样式和模板
3.然后选择源文件需要被拆分的内容开始的行数，如下图，开始的行数就是2

4.选择源文件需要被拆分的内容开始的列数，如上图，开始的列可以为2，也可以为3，最好与模板的列数保持一致。
   然后选择拆分的文件以哪一列命名，案例中我选择的是按原表中的名称字段。
5.选择模板插入数据的位置，如下图模板数据开始位置就是A2 ：

6.然后点击拆分，结果会自动生成到运行目录下’拆分文件‘目录中（如果没有这个文件夹会自动新建）：



下载地址：https://wwz.lanzoul.com/iNV99034h23a        解压密码：52pojie

lizhipei78

gcb119 发表于 2022-4-13 16:38
支持楼主继续优化：
excel必备工具拆分规则大概有两种模式
拆分的一般理解为对行的拆分，列的拆分参数可 ...

都是为了纯粹的拆分，都不保持原来的行列宽高、页面距离，拆分出来没法看，不能直接打印（效果不好）。目前看到能保持原格式（即模板）拆分的是Excel工作圈插件(exe)版本的，方方格子好像也可以。但是拆分的原理好像是复制工作表，然后删除不符合的，这样子速度好慢。但是楼主这种以值的方式拆分到模板中的思路拆分，速度是很快的。我自己写代码也是这种思路。

我用的代码
Sub 按列拆分成工作薄()
    t = Timer
    dir_name = ThisWorkbook.Path & "\生成的表格\"
    If Dir(dir_name, vbDirectory) = "" Then
        MkDir (dir_name)
    End If
    Sheets("数据源").Select
    On Error Resume Next
    Application.ScreenUpdating = False '停止屏幕刷新
    Application.DisplayAlerts = False '停止警告
    Dim r1%, r2%, arr, ws As Worksheet, d As Object, brr()
    Set d = CreateObject("scripting.dictionary")
    arr = Range("a1").CurrentRegion
    ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    For i = 1 To UBound(arr)
        d(arr(i, 5)) = "" '要分列在第5列
    Next i
    a = d.Keys
    For i = 1 To d.Count - 1
        s = 0
        For j = 1 To UBound(arr)
            If arr(j, 5) = a(i) Then '要分列在第5列
                s = s + 1
                For k = 1 To UBound(arr, 2)
                    brr(s, k) = arr(j, k)
                Next k
            End If
        Next j
        Sheets("模板").Range("a1") = "2021年 " & a(i) & " 享受政策一览表"
        Sheets("模板").Range("a4").Resize(s, UBound(brr, 2) - 1) = brr '复制内容到分表中
        '复制“模板”工作表
        Sheets("模板").Copy
        '删除空白行
        r2 = Range("A200").End(3).Row
        Range("D200:A" & r2 + 1).Clear
        'Range("a5:a200").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        'r1 = Range("a200").End(3).Row
        'Range(Cells(r1 + 1, 1), Cells(200, 4)).Clear
        '工作簿另存为
        ActiveWorkbook.Close SaveChanges:=True, Filename:=dir_name & a(i) & ".xlsx"
        '清空模板数据
        Sheets("模板").Range("A4：F200").ClearContents
    Next i
    Application.ScreenUpdating = True '开启屏幕刷新
    Application.DisplayAlerts = True '开启删除警告
    t = Timer - t
    MsgBox "完成，用时" & t & "秒"
End Sub

maxtm

拆分的文件找不到，拆分文件夹里没有。

mystictaki

666，楼主加油

shiym3288

多谢分享。下来收藏

hfxiang

这个工具合适于人力资源部使用。感谢分享

huzp

强大，很不错，支持

wohushan

感谢楼主提供

yj2002525758

感谢楼主无私奉献

wqccwang

谢谢  下载备用

zxdjadl

感谢楼主,下载试试！

imcoder

好像很厉害