将1工作簿中多个工作表的数据按照列名拆分成多个工作簿

卧室交锋 · 发表于 2016-8-1 08:23

本帖最后由卧室交锋于 2016-8-1 09:12 编辑

lsc900707 发表于 2016-7-31 23:09
建议上传附件以便查找原因。

下面又重新传了附件。

魂断蓝桥 · 发表于 2016-8-1 08:27

星凝发表于 2016-3-14 15:22
大师，能否帮忙修改一下代码，使得拆分后的数据保留原数据的格式！
这个数据拆分困扰了我一年了！感谢！

如果需要保留原来的格式，

需要用复制、粘贴

也就是说，需要通过筛选-复制-粘贴达到目的。

你能传一个具体的附件？

卧室交锋 · 发表于 2016-8-1 09:10

魂断蓝桥发表于 2016-8-1 08:27
如果需要保留原来的格式，

需要用复制、粘贴

大师，我只需要对一个表的详细部分列进行拆分，目前我修改了能够拆分，运行结束时提示“运行错误9，下标越界”。另外表里的字体颜色没有了，能不能帮忙看看，我要把数据按照详细部门分成一个一个的excel文件发到每个科室让他们补充修改数据库。万分感谢了。

魂断蓝桥 · 发表于 2016-8-1 10:01

卧室交锋发表于 2016-8-1 09:10
大师，我只需要对一个表的详细部分列进行拆分，目前我修改了能够拆分，运行结束时提示“运行错误9，下标 ...

163 个工作簿，

Sub a()
Dim d, k, i As Integer, arr, tb
Set tb = ActiveSheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
arr = Sheet1.[a1].CurrentRegion
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(arr)
If arr(i, 2) = "" Then
      MsgBox "第" & i + 1 & "行，部门为空,请添加部门后再运行"
      Exit Sub
Else
      d(arr(i, 2)) = ""
End If
Next
k = d.keys
For i = 0 To d.Count - 1
[a2].AutoFilter Field:=2, Criteria1:=k(i)
If Dir(ThisWorkbook.Path & "\" & k(i) & ".xlsx") = "" Then
      Workbooks.Add
      tb.Range("a1:ee" & tb.[b65536].End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy [a2]
Else
      Workbooks.Open k(0) & ".xlsx"
      [a1].CurrentRegion.Offset(1, 0).ClearContents
      tb.Range("a2:ee" & tb.[a65536].End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy [a2]
End If
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & k(i) & ".xlsx"
ActiveWorkbook.Close True
Next
Set d = Nothing
[a2].AutoFilter
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "OK"
End Sub

卧室交锋 · 发表于 2016-8-1 15:15

太好用了，效率高速度快，一共2400多行，每行150列，格式包括设置的条件格式都保留在新表里了。谢谢！谢谢！谢谢！
另外，拆分完毕后关闭总表时不管是否保存都提示：“图片太大，超过部分将被截去。”，强行关闭或者等一会就好了。
其实是两行表头，最上面还有一行，有些是单元格合并的，大师能够拆分时保留2行表头吗。上附件。

魂断蓝桥 · 发表于 2016-8-1 16:21

卧室交锋发表于 2016-8-1 15:15
太好用了，效率高速度快，一共2400多行，每行150列，格式包括设置的条件格式都保留在新表里了。谢谢！谢谢 ...

用这个试一试。

按列拆分人力资源信息审核修改附件.rar (89.54 KB, 下载次数: 130)

拆分161，没看到你说的提示。

_留柳_ · 发表于 2017-2-8 15:34

魂断蓝桥发表于 2014-11-17 10:55
Sub cf()
Dim cnn As Object, rs As Object, SQL$, sFile$, i&, J&
Dim msg As VbMsgBoxResult

大神，这个我自己试了下，确实拆分成功了，但是格式字体颜色等全没了，再调格式就更慢了。而且最后还出现“运行时错误'9'；下标越界”。我也上传了我每个月要拆分的表，希望大神能够帮忙，不胜感激。
一个excel工作薄中有三个表，分别命名“内部”、“外部”、“比价处理结果”，

内部表按照“高价公司”拆分；
外部表按照“公司”拆分；
比价处理结果不拆分，每个表都需要有。
希望大神能帮忙，拆分后能够保留原有格式，非常感谢。