標題: [發問] 請問如何依篩選欄的類別,自動建立分頁建立後並分類資料? [打印本頁]

---

作者: starry1314    時間: 2015-8-24 17:16     標題: 請問如何依篩選欄的類別,自動建立分頁建立後並分類資料?

目前須手動建立篩選欄位內的分頁才能自動導入資料

1. Sub Ex()
   
2.     Dim Sh As Worksheet
   
3.     With Sheets("彙總明細")
   
4.         For Each Sh In Sheets          'Sheets : 工作表物件的集合物件
   
5.             If Sh.Name <> .Name Then   '工作表的名稱<>"彙總明細"
   
6.                 .Range("A1").AutoFilter Field:=2, Criteria1:=Sh.Name
   
7.                 '"彙總明細" 自動篩選  篩選基準欄位:=第2欄 , 篩選準則:="工作表名稱"
   
8.                 .UsedRange.Columns("a:d").Copy Sh.[a1] '"彙總明細" 自動篩選後的資料, 複製
   
9.             End If
   
10.         Next
    
11.         .Range("A1").AutoFilter   '取消 "彙總明細"自動篩選模式
    
12.     End With
    
13. End Sub

複製代碼

---

作者: 准提部林    時間: 2015-8-31 18:49

Sub test()
Dim Sht As Worksheet, xD, xR As Range
Set xD = CreateObject("Scripting.Dictionary")
xD("") = 1
With Sheets("彙總明細").UsedRange
　　For Each xR In .Columns(2).Offset(1, 0).Cells
　　　　If xD(xR.Value) = "" Then
　　　　　On Error Resume Next
　　　　　Set Sht = Sheets(xR.Value)
　　　　　On Error GoTo 0
　　　　　If Sht Is Nothing Then Sheets.Add(after:=Sheets(Sheets.Count)).Name = xR.Value
　　　　　.AutoFilter Field:=2, Criteria1:=xR.Value
　　　　　.Columns("a:d").Copy Sheets(xR.Value).[a1]
　　　　　xD(xR.Value) = 1: Set Sht = Nothing
　　　　End If
　　Next
　　Application.Goto .Item(1)
End With
Sheets("彙總明細").AutoFilterMode = False
End Sub
　

---

作者: starry1314    時間: 2015-9-1 12:00

回復 2# 准提部林

太感謝你了！！！！！！！！！！！！！！！！！！

---

作者: GBKEE    時間: 2015-9-1 12:49

進階篩選+自動篩選

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Sh As Worksheet, Ar As Variant, i As Integer, M As Variant
   
4.     With ActiveWorkbook.Sheets("彙總明細")
   
5.         .Range("b:b").AdvancedFilter xlFilterCopy, , .Cells(1, .Columns.Count), True
   
6.         With .Cells(1, .Columns.Count).EntireColumn
   
7.             Ar = .SpecialCells(xlCellTypeConstants)
   
8.             Ar = Application.WorksheetFunction.Transpose(Ar)
   
9.             .Cells = ""
   
10.         End With
    
11.         On Error GoTo Sheet_Add   '處裡工作表不存在的錯誤
    
12.         For i = 2 To UBound(Ar)
    
13.             .Range("A1").AutoFilter Field:=2, Criteria1:=Ar(i)
    
14.             .UsedRange.Columns("a:d").Copy ActiveWorkbook.Sheets(Ar(i)).[a1] '"彙總明細" 自動篩選後的資料, 複製
    
15.         Next
    
16.         .Range("A1").AutoFilter   '取消 "彙總明細"自動篩選模式
    
17.         .Activate
    
18.         On Error GoTo 0             '程式有錯誤不處裡
    
19.         '刪除工作表不存"彙總明細"篩選欄的類別
    
20.         Application.DisplayAlerts = False
    
21.         For Each Sh In ActiveWorkbook.Sheets
    
22.             If Sh.Name <> .Name Then If IsError(Application.Match(Sh.Name, Ar, 0)) Then Sh.Delete
    
23.         Next
    
24.         Application.DisplayAlerts = True
    
25.     End With
    
26.     Exit Sub
    
27. '******************************
    
28. Sheet_Add:
    
29.      ActiveWorkbook.Sheets.Add.Name = Ar(i)
    
30.     Resume
    
31. End Sub

複製代碼

---

作者: starry1314    時間: 2015-9-2 13:26

回復 4# GBKEE

感謝版大~努力吸收！！！

---

歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)