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