VBA拆分工具

 

Sub XXX_Click()
'输入用户想要拆分的工作表
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 workbook_path, xlAddIn8

    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