将汇总表分解成多个工作表

liuzhenhua

修理费（汇总）中1-45行为表头部分，46行以下为数据部分，数据行数不固定。
要将数据按B列不同设备编号重新生成以设备编号命名的单个工作表，
表头复制汇总表前45行，
46行已下复制本设备编号中的数据
形成像“执行程序后”那样的形式
设备数量非常多每个月一个一个复制太麻烦
请帮忙编个程序（表中的颜色是为了方便看加上去的，编程不用考虑）
谢谢

LangQueS

建议楼主参考下帖附件中的文字说明，修改工作表的设置，首先要建立好记录日常所发生数据的“一维数据表”。我们的目的是使用好Excel，实现对数据的管理，而不是制作软件。因此要充分发挥 Excel 自带的强大功能，例如“高级筛选”、“数据透视表”等等，再用函数和代码等方法作为补充，以降低制作和修改难度，提高工作效率。

★Excel数据管理的一般规律★    http://club.excelhome.net/thread-287461-1-1.html

liuzhenhua

LangQueS 发表于 2013-7-27 16:38
建议楼主参考下帖附件中的文字说明，修改工作表的设置，首先要建立好记录日常所发生数据的“一维数据表”。 ...

其实我的附件中那个汇总表已经很直观了，领导还嫌不直观，她非要每个设备做一个表，高级筛选，透视表我会，但是还要一个一个的按设备编号复制成单个表，工作量挺大，我苦恼极了

excel好玩

liuzhenhua 发表于 2013-7-27 16:46
其实我的附件中那个汇总表已经很直观了，领导还嫌不直观，她非要每个设备做一个表，高级筛选，透视表我会 ...

1. Sub test()
   
2.     Dim i&, k&, myrow&, arr, sht, mysht
   
3.     Set mysht = ActiveSheet
   
4.     myrow = mysht.UsedRange.Rows.Count
   
5.     arr = Range("b46:b" & myrow + 1)
   
6.     i = 46
   
7.     Application.DisplayAlerts = False
   
8.     Application.ScreenUpdating = False
   
9.     For Each sht In Sheets
   
10.         If sht.Name <> mysht.Name And sht.Name <> Sheets(2).Name Then
    
11.             sht.Delete
    
12.         End If
    
13.     Next
    
14.     For k = 1 To UBound(arr) - 1
    
15.         If arr(k, 1) <> arr(k + 1, 1) Then
    
16.             Sheets(2).Copy after:=Sheets(Sheets.Count)
    
17.             With Sheets(Sheets.Count)
    
18.                 .Name = arr(k, 1)
    
19.                 mysht.Range("a" & i & ":q" & 45 + k).Copy .[a46]
    
20.             End With
    
21.             i = 46 + k
    
22.         End If
    
23.     Next
    
24.     mysht.Activate
    
25.     Application.DisplayAlerts = True
    
26.     Application.ScreenUpdating = True
    
27. End Sub

复制代码

附件如下

蓝桥玄霜

1. Sub lqxs()
   
2.     Dim col%, Myr&, Arr, d, k, i&, j&, aa
   
3.     Dim Sht As Worksheet, Sht1 As Worksheet
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7.     Set Sht1 = ActiveSheet
   
8.     For Each Sht In Sheets
   
9.         If Sht.Name <> Sht1.Name And Sht.Name <> "模板" Then Sht.Delete
   
10.     Next Sht
    
11.     col = 2
    
12.         On Error Resume Next
    
13.     Myr = [b65536].End(xlUp).Row
    
14.     Arr = Range("a1:q" & Myr)
    
15.     For i = 46 To UBound(Arr)
    
16.         d(Arr(i, col)) = d(Arr(i, col)) & i & ","
    
17.     Next
    
18.     k = d.keys: t = d.items
    
19.     For i = 0 To UBound(k)
    
20.         Sheets("模板").Copy after:=Sheets(Sheets.Count)
    
21.         ActiveSheet.Name = k(i)
    
22.         t(i) = Left(t(i), Len(t(i)) - 1)
    
23.         If InStr(t(i), ",") Then
    
24.             aa = Split(t(i), ",")
    
25.             For j = 0 To UBound(aa)
    
26.                 With ActiveSheet
    
27.                     .Cells(j + 46, 1).Resize(1, UBound(Arr, 2)) = Application.Index(Arr, aa(j), 0)
    
28.                 End With
    
29.             Next
    
30.         Else
    
31.             With ActiveSheet
    
32.                 .Cells(46, 1).Resize(1, UBound(Arr, 2)) = Application.Index(Arr, t(i), 0)
    
33.             End With
    
34.         End If
    
35.         [a46].Select
    
36.     Next
    
37.     Sht1.Activate
    
38.     Set d = Nothing
    
39.     Application.DisplayAlerts = True
    
40.     Application.ScreenUpdating = True
    
41. End Sub
    
42. 
    

复制代码

liuzhenhua

excel好玩 发表于 2013-7-27 16:49
附件如下

谢谢
这样简单多了
万分感谢

蓝桥玄霜

请见附件。

此用户被禁言

1. Sub 按条件分表()
   
2. Set d = CreateObject("scripting.dictionary")  '定义一个字典
   
3. arr = Sheet1.Range("b46:b" & Cells(Rows.Count, 2).End(xlUp).Row).Value '将A列的所有内容依次写入数组
   
4. Application.ScreenUpdating = False
   
5. For i = 1 To UBound(arr) '循环到A列结束
   
6.     d(arr(i, 1)) = ""    '关键字依次获取A列不重复的条件
   
7. Next
   
8. arr2 = d.keys  '将关键字赋值给数组arr2
   
9. For k = 1 To d.Count
   
10.     Sheets.Add after:=Sheets(Sheets.Count)
    
11.     Sheets("Sheet" & k).Name = arr2(k - 1)
    
12. Next
    
13. With Sheet1    '在需要筛选的工作表中循环
    
14.      .Rows(46).Insert
    
15. For i = 1 To UBound(arr2) + 1 '在关键字中循环
    
16.     .Rows("1:45").Copy Sheets(arr2(i - 1)).Range("A1")
    
17.     .Range("a46:q" & .Cells(Rows.Count, 1).End(xlUp).Row).AutoFilter Field:=2, Criteria1:=arr2(i - 1)     '筛选
    
18.     .AutoFilter.Range.SpecialCells(12).Copy Sheets(arr2(i - 1)).Range("a46") '使用specialcells将筛选的所有内容粘贴对应工作表
    
19.      Sheets(arr2(i - 1)).Rows(46).Delete
    
20. Next
    
21.     .ShowAllData '最终取消筛选的条件
    
22.     .Rows(46).Delete
    
23. End With
    
24. Application.ScreenUpdating = True
    
25. End Sub

复制代码

我使用了筛选的方法去操作，你的下面标题行有合并单元格，所以我做了一下处理去筛选，然后复制粘贴

bluexuemei

1. Sub bxm()
   
2. Application.DisplayAlerts = False
   
3. Dim sh As Worksheet, i&, j&, k, di, d
   
4. Set d = CreateObject("scripting.dictionary")
   
5. For Each sh In Sheets
   
6.    If sh.Name <> "修理费（汇总）" Then sh.Delete
   
7. Next
   
8. For i = 46 To [b65536].End(3).Row
   
9.     If Not d.Exists(Cells(i, 2).Value) Then
   
10.        Set d(Cells(i, 2).Value) = Sheet1.Rows(i)
    
11.     Else
    
12.        Set d(Cells(i, 2).Value) = Union(d(Cells(i, 2).Value), Sheet1.Rows(i))
    
13.     End If
    
14. 
    
15. Next
    
16. k = d.keys
    
17. di = d.items
    
18. For j = 0 To d.Count - 1
    
19.     Worksheets.Add after:=Sheets(Sheets.Count)
    
20.     ActiveSheet.Name = k(j)
    
21.     Sheet1.Rows("1:45").Copy ActiveSheet.[a1]
    
22.     ActiveSheet.[d3] = k(j)
    
23.     di(j).Copy ActiveSheet.[a46]
    
24. Next
    
25. Set d = Nothing
    
26. Stop
    
27. Application.DisplayAlerts = True
    
28. End Sub
    

复制代码

liuzhenhua

都是高手
在下学习了