[已解决]将一表按某列不同单位分解为分表

ZMW

附1.zip (20.18 KB, 下载次数: 10)

2014-12-9 11:34 上传

点击文件名下载附件



    请问各位大师：如何用VBA将像样表1的表格内容，按照张一、李四、王六三个单位分别分解到表2、3、4？编写的代码最后要能将本文件夹内的接近实际表进行分解，谢谢！！！http://www.excelpx.com/thread-334079-1-1.html第9楼，附件。因网络问题不好上传，谢谢。

最佳答案

月排行榜 / 总排行榜

Excel学徒123

2014-12-9 20:21

ZMW 发表于 2014-12-9 20:04
你好,我是想将本工作表按A 列的不同单位名称,拆分成一一个个工作薄,如一楼所示,因为我的工作表数据太 ...

我这是两个子过程，第一个是分表，第二个是将分出来的表分成工作簿，当第一个子过程运行完毕之后自动调用第二个子过程，行不行你运行了不就知道了？保存的新工作簿位置就是你这个文件的位置下面。

跳转到最佳答案楼层

tgydslr

1、上传附件
2、一个小建议：要是对代码有些基础的话，建议这样做，然后消化修改，否则的话还是建议用公式什么的好些，毕竟那样理解起来更好些，当然了，数据量特大的话除外

爱疯

没附件，不好说。44看
http://www.excelpx.com/thread-297695-1-1.html

Excel学徒123

附件哟...

ZMW

tgydslr 发表于 2014-12-9 10:33
1、上传附件
2、一个小建议：要是对代码有些基础的话，建议这样做，然后消化修改，否则的话还是建议用公式 ...

http://www.excelpx.com/thread-334079-1-1.html第9楼，附件。因网络问题不好上传，谢谢

Excel学徒123

你是要分成单独的工作簿？

Excel学徒123

1. Sub 生成工作表()
   
2.     Dim Arr, Arr1, Arr2(1 To 10000, 1 To 28)
   
3.     Dim i%, j%, k%, Intarr, Tx
   
4.     Dim Dic
   
5.     Dim Sh
   
6.     Application.ScreenUpdating = False
   
7.     Application.DisplayAlerts = False
   
8.     On Error Resume Next
   
9.     For Each Sh In Worksheets
   
10.         If Sh.Name <> "Sheet1" Then
    
11.             Sh.Delete
    
12.         End If
    
13.     Next
    
14.     Arr = Sheets("Sheet1").Range("A2:A" & Cells(Rows.Count, 1).End(3).Row)
    
15.     Arr1 = Sheets("Sheet1").Range("a2:ab" & Cells(Rows.Count, 1).End(3).Row)
    
16.     Set Dic = CreateObject("scripting.dictionary")
    
17.     For i = 1 To UBound(Arr)
    
18.         Dic(Arr(i, 1)) = ""
    
19.     Next i
    
20.     For j = 1 To Dic.Count
    
21.         Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = Application.Index(Dic.keys, j)
    
22.         Sheets("Sheet1").Range("A1:AB1").Copy Sheets(Application.Index(Dic.keys, j)).Range("A1")
    
23.         Sheets(Application.Index(Dic.keys, j)).Range("1:1").RowHeight = 70
    
24.     Next j
    
25.     For j = 1 To Dic.Count
    
26.         For k = 1 To UBound(Arr1)
    
27.             If Arr1(k, 1) = Application.Index(Dic.keys, j) Then
    
28.                 Tx = Tx + 1
    
29.                 For Intarr = 1 To 28
    
30.                     Arr2(Tx, Intarr) = Arr1(k, Intarr)
    
31.                 Next Intarr
    
32.             End If
    
33.           Next k
    
34.         Sheets(Application.Index(Dic.keys, j)).Range("a2").Resize(k, 28) = Arr2
    
35.         Tx = 0
    
36.     Next j
    
37.     Call 拆分工作簿
    
38.     ActiveWindow.Close
    
39.     Application.ScreenUpdating = True
    
40.     Application.DisplayAlerts = True
    
41. End Sub
    
42. '>分割线================================================================================================================================分割线
    
43. Sub 拆分工作簿()
    
44.   Dim i, mbook As Workbook
    
45.   Application.ScreenUpdating = False
    
46.   Set mbook = ActiveWorkbook
    
47.   For i = 1 To Sheets.Count
    
48.     mbook.Sheets(i).Copy
    
49.     ActiveWorkbook.SaveAs ThisWorkbook.Path & "" & mbook.Sheets(i).Name & ".xls"
    
50.     ActiveWindow.Close
    
51.   Next
    
52.   Application.ScreenUpdating = True
    
53. End Sub
    

复制代码

复制吧，应该是你要的效果了{:1012:}

ZMW

Excel学徒123 发表于 2014-12-9 13:39
复制吧，应该是你要的效果了

拆分成张一、王五、李六，三个工作薄。

Excel学徒123

ZMW 发表于 2014-12-9 16:02
拆分成张一、王五、李六，三个工作薄。

复制上面的代码，就是那样做的
把表头放到A1去，上面不要空3行
下附件

ZMW

Excel学徒123 发表于 2014-12-9 16:10
复制上面的代码，就是那样做的
把表头放到A1去，上面不要空3行
下附件

    你好,我是想将本工作表按A 列的不同单位名称,拆分成一一个个工作薄,如一楼所示,因为我的工作表数据太多大,原先的老师编个代码运行中有点问题,他也忘记解决了,所以求教.不是你现在的代码将现有的工作薄拆分成表或案件和SHEET1的样式,请你再次看看,谢谢!!