[已解决]求助拆分代码

chensir

求助，按品牌拆分基础表，拆成基础表-AD和基础表-NK，同时相应的批注也随之而行。(最好拆分好的表格只是数值和批注) 求助代码。多谢，多谢。

最佳答案

月排行榜 / 总排行榜

dsmch

2014-12-4 12:57

………………

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Dim arr, d, i&, j%
   
4. Application.ScreenUpdating = False
   
5. Application.DisplayAlerts = False
   
6. For i = Sheets.Count To 1 Step -1
   
7.     If Sheets(i).Name <> "基础表" Then Sheets(i).Delete
   
8. Next
   
9. arr = Sheet1.Range("a1").CurrentRegion
   
10. Set d = CreateObject("scripting.dictionary")
    
11. For i = 2 To UBound(arr)
    
12.     If Not d.exists(arr(i, 3)) Then d(arr(i, 3)) = i Else d(arr(i, 3)) = d(arr(i, 3)) & "," & i
    
13. Next
    
14. a = d.keys: b = d.items
    
15. For i = 0 To d.Count - 1
    
16.     x = Split(b(i), ",")
    
17.     If Sheets(a(i)) Is Nothing Then
    
18.         With Sheets.Add(after:=Sheets(Sheets.Count))
    
19.             Sheet1.Rows(1).Copy .[a1]
    
20.             For j = 0 To UBound(x)
    
21.                 Sheet1.Cells(x(j), 1).Resize(1, UBound(arr, 2)).Copy .Cells(j + 2, 1)
    
22.             Next
    
23.             .Name = "基础表-" & a(i)
    
24.         End With
    
25. End If
    
26. Next
    
27. Sheet1.Activate
    
28. Application.DisplayAlerts = True
    
29. Application.ScreenUpdating = True
    
30. End Sub

复制代码

dsmch

………………