灵活拆分工具

朱荣兴 · 发表于 2017-6-13 09:16

提示: 作者被禁止或删除内容自动屏蔽

amzxfgh9632 · 发表于 2017-6-13 11:57

朱荣兴发表于 2017-6-13 09:16
代码是带格式拷贝的，行高应该是原样的呀，

不一样，我测试过，谢谢

jaffedream · 发表于 2017-6-16 09:34

楼主，我把你的代码改了下，这样不依赖窗体了，采用对话框输入所要的值就行：

Sub TEST()
'Private Sub CommandButton1_Click() '可绑定在命令按钮上
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim arr As Variant
Dim i, s As Integer
Dim brr()
Dim wb, wb1 As Workbook
Dim d As Object
Dim hlrow As Integer, cutcolumn As Integer, cuttype As Integer
Set d = CreateObject("scripting.dictionary")
Dim sh As Worksheet
hlrow = InputBox("请输入标题行数：", "拆分表格", "1")
cutcolumn = InputBox("请输入拆分列（第一列是1，第二列是2，以此类推）：", "拆分表格", "1")
cuttype = InputBox("请选择拆分类型（拆分到本工作簿是1，拆分为多个独立工作簿是2，拆分为一个工作簿是3）：", "拆分表格", "1")
If cuttype = 1 Then
For Each sh In Worksheets
If sh.Name <> ActiveSheet.Name Then sh.Delete
Next sh
End If
arr = ActiveSheet.Range("a1").CurrentRegion
For i = hlrow + 1 To UBound(arr)
If Not d.exists(arr(i, cutcolumn)) Then
Set d(arr(i, cutcolumn)) = ActiveSheet.Range("a" & i).Resize(1, UBound(arr, 2))
Else
Set d(arr(i, cutcolumn)) = Union(d(arr(i, cutcolumn)), ActiveSheet.Range("a" & i).Resize(1, UBound(arr, 2)))
End If
Next i
If cuttype = 3 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 cuttype = 1 Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = x(k)
ThisWorkbook.Worksheets(1).Rows("1:" & hlrow).Copy ActiveSheet.[a1]
d.items()(k).Copy ActiveSheet.Cells(hlrow + 1, 1)
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 cuttype = 2 Then
Application.SheetsInNewWorkbook = 1
Set wb = Workbooks.Add
With wb.Worksheets(1)
ThisWorkbook.Worksheets(1).Rows("1:" & hlrow).Copy .[a1]
d.items()(k).Copy .Cells(hlrow + 1, 1)
For i = 1 To UBound(arr, 2)
.Columns(i).ColumnWidth = ThisWorkbook.ActiveSheet.Columns(i).ColumnWidth
Next i
wb.SaveAs Filename:=ThisWorkbook.Path & "" & x(k) & ".xls"
wb.Close
End With
End If
If cuttype = 3 Then
ThisWorkbook.Worksheets(1).Rows("1:" & hlrow).Copy wb1.Worksheets(x(k)).[a1]
d.items()(k).Copy wb1.Worksheets(x(k)).Cells(hlrow + 1, 1)
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 cuttype = 3 Then
wb1.SaveAs Filename:=ThisWorkbook.Path & "" & "拆分数据表.xls"
wb1.Close False
End If
End
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

复制代码

jaffedream · 发表于 2017-6-16 11:31

这个代码我也改了，原来的代码是固定指向第12列的，而且表头是三行，现在应该可以自定义了：

Sub 批量拆分为独立工作薄()
Application.ScreenUpdating = False
Dim wb, wb1 As Excel.Workbook
Dim sh As Excel.Worksheet
Dim d As Object
Dim arr As Variant
Dim i, s As Integer
Dim hlrow As Integer, cutcolumn As Integer
hlrow = InputBox("请输入标题行数：", "拆分表格", "1")
cutcolumn = InputBox("请输入拆分列（第一列是1，第二列是2，以此类推）：", "拆分表格", "1")
Application.SheetsInNewWorkbook = 1
Set d = CreateObject("scripting.dictionary")
Set fso = CreateObject("Scripting.FileSystemObject")
sfolder = ThisWorkbook.Path & "\结果"
If fso.folderexists(sfolder) Then
fso.deletefolder sfolder
End If
fso.CreateFolder sfolder
f = Dir(ThisWorkbook.Path & "\*.xls*") '生成查找EXCEL的目录,可以适应不同版本
Do While f <> "" '在目录中循环
If f <> ThisWorkbook.Name Then '如果不是打开的工作簿
Set wb = Workbooks.Open(ThisWorkbook.Path & "" & f) '依次打开目录工作薄
arr = wb.Worksheets(1).UsedRange
For i = 4 To UBound(arr)
If Not d.exists(arr(i, cutcolumn)) Then
Set d(arr(i, cutcolumn)) = wb.Worksheets(1).Range("a" & i).Resize(1, UBound(arr, 2))
Else
Set d(arr(i, cutcolumn)) = Union(d(arr(i, cutcolumn)), wb.Worksheets(1).Range("a" & i).Resize(1, UBound(arr, 2)))
End If
Next i
x = d.keys
For i = 0 To UBound(x)
Set wb1 = Workbooks.Add
wb.Worksheets(1).Rows("1:" & hlrow).Copy wb1.Worksheets(1).Range("A1")
d.items()(i).Copy wb1.Worksheets(1).Range("A" & hlrow + 1)
wb1.SaveAs Filename:=ThisWorkbook.Path & "\结果" & Split(wb.Name, ".")(0) & x(i) & ".xlsx"
wb1.Close False
Next i
wb.Close False '关闭打开的工作薄
d.RemoveAll
End If
f = Dir
Loop '结束循环
Application.ScreenUpdating = True
End Sub

复制代码

steflolly · 发表于 2017-6-16 21:28

大家好厉害，学习了！

朱荣兴 · 发表于 2017-6-16 21:42

提示: 作者被禁止或删除内容自动屏蔽

taoguohui · 发表于 2017-6-22 16:53

好工具，收藏备用。

asd492751586 · 发表于 2017-7-3 07:39

朱老师，下标越界是为什么？

libuyansh · 发表于 2017-7-13 13:08

谢谢楼主提供的代码，学习了！

gyin1989 · 发表于 2017-7-18 11:29

朱荣兴发表于 2017-4-1 12:42

打开已拆分后的工作薄，总出现打“您尝试打开的文件“****.xls”的格式与文件扩展名指定的格式不一致。打开文件前请验证文件没有损坏且来源可信，是否立即打开该文件？”
原数据是.xlsx的，这个代码要怎么改才能不出现这个提示。

		自动登录	找回密码
密码			免费注册

[分享] 灵活拆分工具

评分

评分

朱荣兴朱荣兴当前离线性别保密 UID 1318548 阅读权限 0 注册时间 2011-2-2 在线时间小时最后登录 1970-1-1 积分 19282 财富分享技术精华头像被屏蔽 TA的精华主题 TA的得分主题	楼主\| 发表于 2017-6-13 09:16 \| 显示全部楼层 [广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★免费下载 ★ ★ 使用帮助★ 提示: 作者被禁止或删除内容自动屏蔽

	回复举报

朱荣兴朱荣兴当前离线性别保密 UID 1318548 阅读权限 0 注册时间 2011-2-2 在线时间小时最后登录 1970-1-1 积分 19282 财富分享技术精华头像被屏蔽 TA的精华主题 TA的得分主题	楼主\| 发表于 2017-6-16 21:42 来自手机 \| 显示全部楼层 [广告] ★用Excel做企业管理系统，Excel服务器学习和下载★ 提示: 作者被禁止或删除内容自动屏蔽

	回复举报