Office_Excel拆分工具

要将Excel按照某个字段拆分为多个分表，在http://www.excelhome.net/找到了一个拆分工具，但存在一些问题，就修改完放出来，点此下载。

解决的问题：

其他Excel中加载宏工具，会造成拆分表头丢失；

第一列前几行有空运行失败；

拆分到本工作簿会把除拆分表以外的其他表删掉，修改为若为拆分字段里的表名则删掉，否则保留。

使用方法

1、打开拆分工具表和要拆分的表，激活要拆分的表窗口（如有弹窗启用宏）

2、开发工具——宏——窗体拆分——执行（若无开发工具Tab，在Excel选项——自定义功能区打开）

3、设置拆分类型和行列设置

扩展

如果要以多个字段作为分组拆分工作表，可在最前面插入一列，将多个字段连接。拆分完成再删除第一列即可。

可在后台代码中取消注释删除第一列的代码。

后台代码

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim arr As Variant
Dim header As Range
Dim i, s As Integer
Dim brr()
Dim wb, wb1 As Workbook
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Dim sh As Worksheet
If ComboBox1.Text = "" Then
MsgBox "请输入标题行数"
Exit Sub
End If
If ComboBox2.Text = "" Then
MsgBox "请输入拆分列"
Exit Sub
End If
If OptionButton1.Value = False And OptionButton2.Value = False And OptionButton3.Value = False Then
MsgBox "请选择拆分类型"
Exit Sub
End If

'获取表头
Set header = ActiveSheet.Rows("1:" & ComboBox1.Text)
'获取各区域字典
arr = ActiveSheet.Range("a" & ComboBox1.Text + 1).CurrentRegion
For i = ComboBox1.Text + 1 To UBound(arr)
If Not d.exists(arr(i, ComboBox2.Text)) Then
Set d(arr(i, ComboBox2.Text)) = ActiveSheet.Range("a" & i).Resize(1, UBound(arr, 2))
Else
Set d(arr(i, ComboBox2.Text)) = Union(d(arr(i, ComboBox2.Text)), ActiveSheet.Range("a" & i).Resize(1, UBound(arr, 2)))
End If
Next i

'如果为拆分到本工作簿，原来就存在拆分字段命名的表，则删除
If OptionButton1.Value = True Then
For Each sh In Worksheets
If d.exists(sh.Name) Then sh.Delete
Next sh
End If

If OptionButton3.Value = True Then
Application.SheetsInNewWorkbook = d.Count
Set wb1 = Workbooks.Add
i = 1
For Each k In d.keys
wb1.Worksheets(i).Name = k
i = i + 1
Next k
End If

x = d.keys
For k = 0 To UBound(x)
'拆分到本工作簿代码
If OptionButton1.Value = True Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = x(k)
   header.Copy ActiveSheet.[a1]
d.items()(k).Copy ActiveSheet.Cells(ComboBox1.Text + 1, 1)
'ActiveSheet.Columns("A:A").Delete Shift:=xlToLeft '如果拆分完成不保留第一列，取消此行注释
    For i = 1 To UBound(arr, 2)
   For Each sh In ThisWorkbook.Worksheets
If sh.Name <> x(k) Then
 Sheets(x(k)).Columns(i).ColumnWidth = sh.Columns(i).ColumnWidth
  End If
  Next sh
  Next i
  End If
'拆分为多个工作簿代码
If OptionButton2.Value = True Then
Application.SheetsInNewWorkbook = 1
  Set wb = Workbooks.Add
With wb.Worksheets(1)
header.Copy .[a1]
d.items()(k).Copy .Cells(ComboBox1.Text + 1, 1)
.Columns("A:A").Delete Shift:=xlToLeft '如果拆分完成不保留第一列，取消此行注释
  For i = 1 To UBound(arr, 2)
  .Columns(i).ColumnWidth = ThisWorkbook.ActiveSheet.Columns(i).ColumnWidth
  Next i
wb.SaveAs Filename:=ThisWorkbook.Path & "" & x(k) & ".xlsx"  '此处可设置在分割字段前或者后加字符组成文件名，也可设置导出路径，默认为此宏工作簿路径
wb.Close
End With
End If
'拆分为一个工作簿代码
If OptionButton3.Value = True Then
header.Copy wb1.Worksheets(x(k)).[a1]
d.items()(k).Copy wb1.Worksheets(x(k)).Cells(ComboBox1.Text + 1, 1)
'wb1.Worksheets(x(k)).Columns("A:A").Delete Shift:=xlToLeft '如果拆分完成不保留第一列，取消此行注释
    For i = 1 To UBound(arr, 2)
  wb1.Sheets(x(k)).Columns(i).ColumnWidth = ThisWorkbook.ActiveSheet.Columns(i).ColumnWidth
  Next i
End If
Next k
If OptionButton3.Value = True Then
wb1.SaveAs Filename:=ThisWorkbook.Path & "" & "拆分数据表.xlsx" '此处可设置导出文件名和导出路径，默认为此宏工作簿路径
wb1.Close False
End If
End
Application.SheetsInNewWorkbook = 3
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton2_Click()
End
End Sub
Private Sub UserForm_Initialize()
Me.ComboBox1.List = Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11")
Me.ComboBox2.List = Array("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")
End Sub