進階篩選

s7659109

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

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

s7659109

版主：若用條件式加迴圈可行嗎？

GBKEE

回復 5# s7659109
    看不懂你要的是什麼,進階篩選無法如此表現.

s7659109

版主：
首先謝謝版主，
我測試了(程式碼貼上了)，還是有問題，只顯示一列，
後面要顯示的資料不見了，我把我想要的顯示的結果放在
應顯示結果工作表中，(測試結果如附檔)
另外結果工作表中date欄的日期格式，要如何
改成2016/01/01

GBKEE

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

是這樣嗎?

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

複製代碼

s7659109

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

GBKEE

回復 1# s7659109
是這樣嗎?

1. Option Explicit
   
2. Sub Ex()
   
3.     With Range("A1:E2319")
   
4.         .Range("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("L1"), Unique:=True
   
5.         With .Range("L1").CurrentRegion
   
6.             .Sort KEY1:=.Cells(1), HEADER:=xlYes
   
7.         End With
   
8.         For I = 2 To .Range("L1").CurrentRegion.Cells.Count
   
9.             .AutoFilter FIELD:=2, Criteria1:=.Range("L1").CurrentRegion.Cells(I)
   
10.             Stop  '看看工作表的自動篩選
    
11.         Next
    
12.         .AutoFilter
    
13.         .Range("L1").CurrentRegion = ""
    
14.     End With
    
15. End Sub

複製代碼