按某个相同的字段自动拆分excel并命名

今天在公司处理表格的时候遇到了一个问题，要把系统导出的租金支付表总表拆分成某一个用户（订单）的分表。

其实就是把表格中订单这一列里相同的行导到同一个表里，并用这个订单号命名。

这里采用VBA宏编程来实现，我用的是excel2016

这里我们可以看到这张大表有很多字段，我们就是要根据合同号把他给拆分开

我们按键盘上的 lctrl + F11 ，弹出VBA页面后点击箭头处小按钮，选“模块”

然后我们把这一段代码粘贴进去

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
Sub 拆分成多个文件()

    '输入用户想要拆分的工作表
    Dim sheet_name
    sheet_name = Application.InputBox("请输入拆分工作表的名称：")
    Worksheets(sheet_name).Select

    '输入获取拆分需要的条件列
    Dim col_name
    col_name = Application.InputBox("请输入拆分依据的列号(如A):")

    '输入拆分的开始行，要求输入的是数字
    Dim start_row As Integer
    start_row = Application.InputBox(prompt:="请输入拆分的开始行:", Type:=1)

    '暂停屏幕更新
    Application.ScreenUpdating = False

    '工作表的总行数
    Dim end_row
    end_row = Worksheets(sheet_name).Range("A65536").End(xlUp).Row

    '遍历计算所有拆分表，每个拆分表的格式为"表名称,表行数"
    '对于二维数组，ReDim只能扩充最后一维，因此sheet_map行不变，扩充列
    Dim sheet_map(), sheet_index
    ReDim sheet_map(1, 0)
    sheet_map(0, 0) = Range(col_name & start_row).Value
    sheet_map(1, 0) = 1
    sheet_index = 0

    With Worksheets(sheet_name)
        Dim row_count, temp, i
        row_count = 0
        For i = start_row + 1 To end_row
            temp = Range(col_name & i).Value
            If temp = Range(col_name & (i - 1)).Value Then
                sheet_map(1, sheet_index) = sheet_map(1, sheet_index) + 1
            Else
                ReDim Preserve sheet_map(1, sheet_index + 1)
                sheet_index = sheet_index + 1
                sheet_map(0, sheet_index) = temp
                sheet_map(1, sheet_index) = 1
            End If
        Next
    End With

    '根据前面计算的拆分表，拆分成单个文件
    Dim row_index
    row_index = start_row
    For i = 0 To sheet_index
        Workbooks.Add
        '创建最终数据文件夹
        Dim dir_name
        dir_name = ThisWorkbook.Path & "\拆分出的表格\"
        If Dir(dir_name, vbDirectory) = "" Then
            MkDir (dir_name)
        End If
        '创建新工作簿
        Dim workbook_path
        workbook_path = ThisWorkbook.Path & "\拆分出的表格\" & sheet_map(0, i) & ".xls"
        ActiveWorkbook.SaveAs Filename:=workbook_path, FileFormat:=-4143
        ActiveSheet.Name = sheet_map(0, i)
        '激活当前工作簿，ThisWorkbook表示当前跑代码的工作簿
        ThisWorkbook.Activate

        '拷贝条目数据(即最前面不需要拆分的数据行)
        Dim row_range
        row_range = 1 & ":" & (start_row - 1)
        Worksheets(sheet_name).Rows(row_range).Copy
        Workbooks(sheet_map(0, i) & ".xls").Sheets(1).Range("A1").PasteSpecial
        '拷贝拆分表的专属数据
        row_range = row_index & ":" & (row_index + sheet_map(1, i) - 1)
        Worksheets(sheet_name).Rows(row_range).Copy
        Workbooks(sheet_map(0, i) & ".xls").Sheets(1).Range("A" & start_row).PasteSpecial
        row_index = row_index + sheet_map(1, i)

        '保存文件
        Workbooks(sheet_map(0, i) & ".xls").Close SaveChanges:=True
    Next

    '进行屏幕更新
    Application.ScreenUpdating = True

    MsgBox "拆分工作表完成"

End Sub

然后我们点右上角的 X 给VBA页面关掉

在开发工具里选择插入一个按钮

我们在表格里画一个不大不小的按钮

然后我们右击按钮，指定宏，宏选择拆分成多个文件，表选择当前表，确定

这样就完成啦~

接下来我们点击按钮试一下

依次按提示输入即可

例如这次，表名写Sheet0，列号写B，开始的行数填2

点确定以后就看到excel自己在执行拆表任务了

稍等一会提示完成后，就可以到拆分出的表格的文件夹里看到拆好的表了~