[已解决]筛选并且复制自动生成表

陈丹青

按B列筛选建表
SUB 建表（）到16则提示内存不够

SUM 建表22（）则A列内容复制不进去，我搞不清，请高手帮我看一下，怎样修改可以将A列复进去，若要把表头也复制到各表应怎样？
谢谢

最佳答案

月排行榜 / 总排行榜

yyyydddd8888

2013-12-9 16:21

请看行不行：
筛选并且复制自动生成表.rar (54.77 KB, 下载次数: 32)

2013-12-9 16:53 上传

点击文件名下载附件

跳转到最佳答案楼层

yyyydddd8888

请看行不行：
筛选并且复制自动生成表.rar (54.77 KB, 下载次数: 32)

2013-12-9 16:53 上传

点击文件名下载附件

轩辕轼轲

1. Option Base 1
   
2. Sub 建表()
   
3.     Dim dic, maxRow%, sArr, tArr(), i%, x%, j%, tSh As Worksheet, tRng As Range, tShape As Shape
   
4.     Set dic = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("入分表")
   
6.         Application.DisplayAlerts = False
   
7.         For i = Sheets.Count To 1 Step -1
   
8.             If Sheets(i).Name <> .Name Then Sheets(i).Delete
   
9.         Next i
   
10.         Application.DisplayAlerts = True
    
11.         maxRow = .Cells(.Columns(2).Rows.Count, 2).End(xlUp).Row
    
12.         sArr = .Range("B2:B" & maxRow)
    
13.         For i = 1 To UBound(sArr, 1)
    
14.             If Not dic.Exists(sArr(i, 1)) Then
    
15.                 x = x + 1
    
16.                 ReDim Preserve tArr(1 To x)
    
17.                 tArr(x) = sArr(i, 1)
    
18.                 dic.Add sArr(i, 1), ""
    
19.             End If
    
20.         Next i
    
21.         For i = 1 To x
    
22.             .Copy After:=Sheets(Sheets.Count)
    
23.             Set tSh = Sheets(Sheets.Count)
    
24.             With tSh
    
25.                 For Each tShape In .Shapes
    
26.                     If tShape.Type = msoFormControl Then tShape.Delete
    
27.                 Next tShape
    
28.                     
    
29.                 .Name = tArr(i)
    
30.                 Set tRng = .Cells(maxRow + 1, 2)
    
31.                 For j = 2 To maxRow
    
32.                     If .Cells(j, 2).Value <> tArr(i) Then Set tRng = Union(tRng, .Cells(j, 2))
    
33.                 Next j
    
34.                 tRng.EntireRow.Delete
    
35.             End With
    
36.         Next i
    
37.     End With
    
38.     Set tSh = Nothing
    
39.     Set dic = Nothing
    
40. End Sub

复制代码

适用于各种情况，无损拆分，不改变源表的任何格式。

陈丹青

谢谢

陈丹青

轩辕轼轲 发表于 2013-12-9 16:53
适用于各种情况，无损拆分，不改变源表的任何格式。

你这个所实现的效果更加好，不过代码比较复杂，我是菜鸟，看不明白。以后有不明白的请多多指教。谢谢！