進階篩選

前輩：
請問進階篩選之巨集，如何改成有迴圈功能(包含篩選準
則，與資料範圍)

Sub 巨集1()
'
' 巨集1 巨集
'

'
Range("G:K").Clear
Range("A1:E2319").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
("L1:L8"), CopyToRange:=Range("G16:K16"), Unique:=False
Range("G16").Select
End Sub

問題.rar (128.1 KB)

樓主熱帖

希望支持!

GBKEE

超級版主 Rank: 8 Rank: 8

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

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

2^#

發表於 2016-9-7 13:58 | 只看該作者

回復 1# s7659109
是這樣嗎?

Option Explicit
Sub Ex()
With Range("A1:E2319")
.Range("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("L1"), Unique:=True
With .Range("L1").CurrentRegion
.Sort KEY1:=.Cells(1), HEADER:=xlYes
End With
For I = 2 To .Range("L1").CurrentRegion.Cells.Count
.AutoFilter FIELD:=2, Criteria1:=.Range("L1").CurrentRegion.Cells(I)
Stop '看看工作表的自動篩選
Next
.AutoFilter
.Range("L1").CurrentRegion = ""
End With
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

TOP

s7659109

中學生 Rank: 2

帖子: 248
主題: 76
精華: 0
積分: 331
點名: 0
作業系統: XP
軟體版本: XP
閱讀權限: 20
性別: 男
來自: kaohsiung
註冊時間: 2013-6-10
最後登錄: 2020-7-3

3^#

發表於 2016-9-8 09:15 | 只看該作者

版主：
你誤會我的意思了，我已重新將問題修正，篩選：條件1(固定不變)
條件2(要有迴圈，因會有增減)，產生如結果

問題1.rar (482.16 KB)

希望支持!

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

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

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

4^#

發表於 2016-9-8 14:08 | 只看該作者

回復 3# s7659109
沒有誤會你的意思,是不知你要問什麼!!

是這樣嗎?

Option Explicit
Sub Ex()
Dim Rng As Range, i As Integer
With Sheets("DATA").UsedRange
.Range("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("條件").Range("F2"), Unique:=True
End With
With Sheets("條件").Range("F2:F" & Sheets("條件").Range("F2").End(xlDown).Row)
.Sort KEY1:=.Cells(1), HEADER:=xlYes
For i = 2 To .Cells.Count
Sheets("條件").Range("a3") = .Cells(i)
Sheets("結果").UsedRange.Clear
With Sheets("DATA").UsedRange
.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("結果").Range("A1"), CriteriaRange:=Sheets("條件").Range("A2:D3")
End With
Stop '看看工作表結果的內容
Next
End With
End Sub