execl中拆分行成单个工作薄（带表头）

1、打开带表头的数据，选择工具栏上面的“开发工具”，进入开发工具界面，就可以进行VB代码的操作了。

2、选择里面的visual basic ，点击进入visual basic 界面，就可以进行行代码的操作。

3、选择visual basic主界面中的“插入”工具选择下拉菜单中的“模板”，进入VB代码主界面。

4、将下面的代码输入“模板”的主界面。

Sub learningexcel()

 Dim Arr, Rng As Range, Sht As Worksheet, Dic As Object

 Dim k, t, Str As String, i As Long, lc As Long

 Application.ScreenUpdating = False '关闭屏幕更新

 Arr = Range("A1").CurrentRegion.Value

 lc = UBound(Arr, 2) '求取最后一列的列号

 Set Rng = Rows(1) '标题行

 Set Dic = CreateObject("Scripting.Dictionary") '创建字典

 For i = 2 To UBound(Arr)

 Str = Arr(i, 3) '关键字，如果要换列，改这个数字即可

 If Not Dic.Exists(Str) Then '如果字典没有关键字

 Set Dic(Str) = Cells(i, 1).Resize(, lc) '把当前行装入到字典中

 Else '否则(字典中存在关键字)

 Set Dic(Str) = Union(Dic(Str), Cells(i, 1).Resize(, lc)) '把行连合起来

 End If

 Next

 k = Dic.Keys '字典关键字集合

 t = Dic.Items '字典项目集合

 On Error Resume Next

 With Sheets

 For i = 0 To Dic.Count - 1 '循环关键字的个数

 Set Sht = .Item(k(i)) '给变量赋值(工作表名为关键字)

 If Sht Is Nothing Then '该工作表不存在则插入一个空工作表

 .Add(After:=.Item(.Count)).Name = k(i) '新建的工作表将置于所有工作表之后，并命名为关键字

 Set Sht = ActiveSheet '活动工作表给变量

 Else '否则

 Sht.Cells.Clear '清除工作中所有内容和格式

 End If

 Rng.Copy Sht.Range("A1") '把标题写入第一行

 t(i).Copy Sht.Range("A2") '写入其他内容

 Sht.Cells.EntireColumn.AutoFit '自动调整全工作表单元格的列宽

 Set Sht = Nothing '变量处于初始状态

 Next

 End With

 Sheets(1).Activate '第1个工作表处于激活状态

 Application.ScreenUpdating = True '打开屏幕更新

End Sub

5、点击主菜单上的快捷运行按钮，等待VB代码运行完成，就可以看到运行的结果了。

6、然后点击visual basic，主菜单上的关闭按钮，就visual basic主界面关闭了，回到execl主界面，就可以看到拆分出来的表格了，点击保存既可。