[已解决]按某列数据拆分工作表的代码(求修改)

徐淑颖

复件 库存.zip (27.94 KB, 下载次数: 50)

2012-10-22 16:31 上传

点击文件名下载附件 各位老师，我有一张工作表，是汇总表！  我想根据第一列的区域数据 ，把汇总表的数据自动拆分成 区域数据工作薄，新表的名称  就用区域 名称就行；   我自己研究了一个下午，可代码还是运行不了，出错；求老师帮忙修改下，谢谢{:011:}

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2012-10-22 18:52

复件 库存.rar (19.92 KB, 下载次数: 372)

2012-10-23 00:13 上传

点击文件名下载附件

跳转到最佳答案楼层

hwc2ycy

小虎子，

徐淑颖

{:011:}亲们，帮忙看下啊！谢谢，我对代码就是个小白，以后学会了好好为大家哦

徐淑颖

hwc2ycy 发表于 2012-10-22 16:56
小虎子，

{:221:}好美的女人啊，帮我解决下呗，亲！

hwc2ycy

元芳，你怎么看？

qjsu

hwc2ycy 发表于 2012-10-22 17:29
元芳，你怎么看？

大神帮我看看这个http://www.excelpx.com/thread-288328-1-1.html

hwc2ycy

其实用数透就可以搞定，

不过你要分工作簿，工作表，应该还是行的，不急撒，晚上帮你写。

hwc2ycy

1. Sub 分类工作簿()
   
2.     Dim dic As Object
   
3.     Dim i&, j&, iQY, k&
   
4.     Dim arr
   
5.     Dim arrTemp
   
6.     Dim arrHead
   
7.     Dim sPath$, sFilename$
   
8.     '关闭屏幕刷新
   
9.     Application.ScreenUpdating = False
   
10.     '关闭警告信息和提示，对于保存文件来说，小心文件覆盖。
    
11.     Application.SheetsInNewWorkbook = 1
    
12.     Application.DisplayAlerts = False
    
13.     Set dic = CreateObject("scripting.dictionary")
    
14.     arrHead = Range(Cells(1, 1), Cells(1, Range("A1").End(xlToRight).Column))
    
15.     sPath = ThisWorkbook.Path & Application.PathSeparator
    
16.     '取工作表数据
    
17.     arr = Range("a1").CurrentRegion
    
18.     For i = 2 To UBound(arr)
    
19.         iQY = arr(i, 1) '区域
    
20.         If Not dic.exists(iQY) Then
    
21.             ReDim arrTemp(1 To 3, 1 To 1)
    
22.             For j = 1 To UBound(arrTemp)    '
    
23.                 arrTemp(j, 1) = arr(i, j)
    
24.             Next
    
25.             dic.Add iQY, arrTemp
    
26.         Else
    
27.             arrTemp = dic(iQY)
    
28.             k = UBound(arrTemp, 2) + 1
    
29.             ReDim Preserve arrTemp(1 To 3, 1 To k)
    
30.             For j = 1 To UBound(arrTemp)
    
31.                 arrTemp(j, k) = arr(i, j)
    
32.             Next
    
33.             dic(iQY) = arrTemp
    
34.             Erase arrTemp
    
35.         End If
    
36.     Next
    
37.     'Erase arrTemp
    
38.     For Each iQY In dic.keys
    
39.         arrTemp = dic(iQY)
    
40.         Workbooks.Add
    
41.         Range("a1").Resize(, UBound(arrHead, 2)) = arrHead
    
42.         Range("a2").Resize(UBound(arrTemp, 2), UBound(arrTemp)) = WorksheetFunction.Transpose(arrTemp)
    
43.         Range("a1").CurrentRegion.Columns.AutoFit
    
44.        ActiveSheet.Name = iQY
    
45.         sFilename = sPath & iQY & ".xls"
    
46.         ActiveWorkbook.SaveAs Filename:=sFilename, FileFormat:=xlExcel7
    
47.         ActiveWorkbook.Close
    
48.      Next
    
49.      MsgBox "数据导出完成"
    
50. End Sub

复制代码

hwc2ycy

复件 库存.rar (19.92 KB, 下载次数: 372)

2012-10-23 00:13 上传

点击文件名下载附件

yuhe0008

何须VBA?
添一辅助列，用数据透视表就可以完成了