[發問] 篩選完後，分別放置不同工作表

jj369963

Dear 大大們：
小問題
1.想以class作為篩選，放置不同sheet
2.並以篩選的class做sheet命名
VBA新手，在煩請指導

發問.rar (13.56 KB)

下載次數: 8

2014-11-30 22:56

GBKEE

回復 1# jj369963

1. Option Explicit
   
2. 
   
3. Sub Ex_字典物件()
   
4.     Dim d As Object, i As Integer, k As Variant, Sh As Worksheet
   
5.     Set d = CreateObject("scripting.dictionary") '字典物件
   
6.     i = 2
   
7.     With Sheet1
   
8.         Do While .Cells(i, "c") <> ""
   
9.             d(.Cells(i, "c") & "") = ""  '字典物件的 key : class欄的值
   
10.             i = i + 1
    
11.         Loop
    
12.         For Each k In d   '字典物件的 key
    
13.             .Range("a1").AutoFilter 3, k  '自動篩選 第3欄的準則為 k
    
14.             On Error Resume Next
    
15.             Set Sh = Sheets(k)        'k工作表不存在會有錯誤
    
16.             If Err <> 0 Then
    
17.                 Set Sh = Sheets.Add(, Sheets(1))
    
18.                 Sh.Name = k
    
19.                 Err.Clear
    
20.                 On Error GoTo 0
    
21.             End If
    
22.             Sh.UsedRange.Clear
    
23.            .UsedRange.Copy Sh.Range("A1")
    
24.         Next
    
25.         .Activate
    
26.         .Range("a1").AutoFilter
    
27.     End With
    
28. End Sub
    
29. Sub Ex_進階篩選()
    
30.     Dim Rng  As Range, Sh As Worksheet
    
31.     With Sheet1
    
32.         '進階篩選出class欄不重複的值
    
33.         .Range("C:C").AdvancedFilter xlFilterCopy, , Cells(1, .Columns.Count), True
    
34.         
    
35.         Set Rng = Cells(2, .Columns.Count)
    
36.         Do While Rng <> ""
    
37.             .Range("a1").AutoFilter 3, Rng  '自動篩選 第3欄的準則為 Rng
    
38.             On Error Resume Next
    
39.             Set Sh = Sheets(Rng.Text)        'Rng.Text 工作表不存在會有錯誤
    
40.             If Err <> 0 Then
    
41.                 Set Sh = Sheets.Add(, Sheets(1))
    
42.                 Sh.Name = Rng.Text
    
43.                 Err.Clear
    
44.                 On Error GoTo 0
    
45.             End If
    
46.             Sh.UsedRange.Clear
    
47.            .UsedRange.Copy Sh.Range("A1")
    
48.             Set Rng = Rng.Offset(1)
    
49.         Loop
    
50.         .Activate
    
51.         .Range("a1").AutoFilter
    
52.         Rng.EntireColumn.Clear
    
53.     End With
    
54. End Sub

複製代碼