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

liuzhenhua

蓝桥玄霜 发表于 2013-7-27 16:58
请见附件。

复制后的数据要是带表格就更完美了

453563050

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

你这种算法有问题，如果更改设备编号字段的内容顺序，就会出现问题
请重新设计算法
详细见附件

蓝桥玄霜

liuzhenhua 发表于 2013-7-27 21:12
复制后的数据要是带表格就更完美了

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.             With ActiveSheet
    
31.                 .Cells(46, 1).Resize(UBound(aa) + 1, UBound(Arr, 2)).Borders.LineStyle = 1
    
32.             End With
    
33.         Else
    
34.             With ActiveSheet
    
35.                 .Cells(46, 1).Resize(1, UBound(Arr, 2)) = Application.Index(Arr, t(i), 0)
    
36.                 .Cells(46, 1).Resize(1, UBound(Arr, 2)).Borders.LineStyle = 1
    
37.             End With
    
38.         End If
    
39.         [a46].Select
    
40.     Next
    
41.     Sht1.Activate
    
42.     Set d = Nothing
    
43.     Application.DisplayAlerts = True
    
44.     Application.ScreenUpdating = True
    
45. End Sub
    

复制代码

hcxxtfy

很好的代码，学习了

Austinwang

bluexuemei 发表于 2013-7-27 18:12

您好，我有类似问题想让老师帮解决一下，将处理表格中数据分解开，期望结果见附件

cqcbc

很好的分解代码，学习了。

LMY123

字典法，根据模板工作表，拆分成工作表

hb-yy

收藏…………。