返回列表 上一主題 發帖

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

starry1314
　暱稱: 豪

高中生Rank: 3Rank: 3

帖子
471 
主題
121 
精華
0 
積分
579 
點名
0  
作業系統
WIN10 
軟體版本
OFFICE2019 
閱讀權限
50 
性別
男 
註冊時間
2015-4-16 
最後登錄
2023-1-17 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 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
複製代碼
收藏 分享

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-25 
2#
發表於 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
　

TOP

starry1314
　暱稱: 豪

高中生Rank: 3Rank: 3

帖子
471 
主題
121 
精華
0 
積分
579 
點名
0  
作業系統
WIN10 
軟體版本
OFFICE2019 
閱讀權限
50 
性別
男 
註冊時間
2015-4-16 
最後登錄
2023-1-17 
3#
發表於 2015-9-1 12:00 | 只看該作者
回復 2# 准提部林

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

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
4#
發表於 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

starry1314
　暱稱: 豪

高中生Rank: 3Rank: 3

帖子
471 
主題
121 
精華
0 
積分
579 
點名
0  
作業系統
WIN10 
軟體版本
OFFICE2019 
閱讀權限
50 
性別
男 
註冊時間
2015-4-16 
最後登錄
2023-1-17 
5#
發表於 2015-9-2 13:26 | 只看該作者
回復 4# GBKEE

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

TOP

        靜思自在 : 人生不一定球球是好球，但是有歷練的強打者，隨時都可以揮棒。
返回列表 上一主題