拆分工作表需求，求大侠帮忙在线等，急用

坏也是一种态度

附件里共有五张表，其中四张都需要按B列名称进行拆分，四张表拆分的工作表按B列名称，同一名称的
放在一个工作簿里面，并把目录表也提取过去，名规则及详细需求见附件
谢谢各位大侠帮忙了急用，在线等

坏也是一种态度

自己顶哈，哪位大侠帮个忙

蓝桥玄霜

分成的每个abcd表只有一行数据？

坏也是一种态度

蓝桥玄霜 发表于 2015-10-26 10:34
分成的每个abcd表只有一行数据？

老师不是滴，因为数据量太大，我把数据删除了，分出的表，表头都是一样的，会有很多行，就按B列进行分，分的时候不要有行限制就行

chxw68

坏也是一种态度 发表于 2015-10-26 10:51
老师不是滴，因为数据量太大，我把数据删除了，分出的表，表头都是一样的，会有很多行，就按B列进行分， ...

我用的是EXCEL2003，打不开你的文件。

坏也是一种态度

chxw68 发表于 2015-10-26 17:45
我用的是EXCEL2003，打不开你的文件。

老师已经转成03的了你看下
里面有五张工作表，其中四张都按B列拆分
目录表直接提取，按B列拆分成多个工作簿每个工作簿同样和数据源表一样有五张表
谢谢老师了，麻烦了

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim wb As Workbook
   
5.   Dim ws As Worksheet
   
6.   Dim d As Object
   
7.   Dim d1 As Object
   
8.   Application.ScreenUpdating = False
   
9.   Application.DisplayAlerts = False
   
10.   Application.SheetsInNewWorkbook = 5
    
11.   Set d = CreateObject("scripting.dictionary")
    
12.   Set d1 = CreateObject("scripting.dictionary")
    
13.   d1("B") = Array("b3:l5", 11, 6)
    
14.   d1("C") = Array("B2:r5", 17, 6)
    
15.   d1("D") = Array("B2:z4", 25, 5)
    
16.   For Each ws In Worksheets
    
17.     flg = Left(ws.Name, 1)
    
18.     If flg Like "[B-D]" Then
    
19.       brr = d1(flg)
    
20.       With ws
    
21.         r = .Cells(.Rows.Count, 2).End(xlUp).Row
    
22.         arr = .Range("b1:b" & r)
    
23.         For i = brr(2) To UBound(arr)
    
24.           If Not d.exists(arr(i, 1)) Then
    
25.             Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
26.           End If
    
27.           If Not d(arr(i, 1)).exists(ws.Name) Then
    
28.             Set d(arr(i, 1))(ws.Name) = .Range(brr(0))
    
29.           End If
    
30.           Set d(arr(i, 1))(ws.Name) = Union(d(arr(i, 1))(ws.Name), .Cells(i, 2).Resize(1, brr(1)))
    
31.         Next
    
32.       End With
    
33.     End If
    
34.   Next
    
35.   For Each aa In d.keys
    
36.     Set wb = Workbooks.Add
    
37.     With wb
    
38.       ThisWorkbook.Worksheets("目录及报表说明").UsedRange.Copy .Worksheets(1).Range("c2")
    
39.       Worksheets(1).Name = "目录及报表说明"
    
40.       m = 2
    
41.       For Each bb In d(aa).keys
    
42.         With Worksheets(m)
    
43.           .Name = bb
    
44.           d(aa)(bb).Copy .Range("b3")
    
45.         End With
    
46.         m = m + 1
    
47.       Next
    
48.       .SaveAs Filename:=ThisWorkbook.Path & "" & "财务数据_" & aa & ".xls"
    
49.       .Close False
    
50.     End With
    
51.   Next
    
52. End Sub
    

复制代码

chxw68

先做了一部分，A表比较特殊，还没有拆分，明天有时间了再完成。

坏也是一种态度

chxw68 发表于 2015-10-26 22:06
先做了一部分，A表比较特殊，还没有拆分，明天有时间了再完成。

嗯嗯好滴，真是太感谢老师你了

坏也是一种态度

chxw68 发表于 2015-10-26 22:06
先做了一部分，A表比较特殊，还没有拆分，明天有时间了再完成。

老师，A表的拆分，那两个表如果行数固定，是不是更好做些