Excel VBA - 自動過濾器和高級過濾器使用錯誤

Question

我有一個需求，我需要使用自動過濾器先過濾數據，然後使用高級過濾器來獲得唯一值。但高級過濾器不會單獨使用自動過濾值。我如何一起使用它們？

這裏去我的代碼，

Colmz = WorksheetFunction.Match("RSDate", Sheets("RS_Report").Rows(1), 0) 

ActiveSheet.ListObjects("RS").Range.AutoFilter Field:=Colmz, Criteria1:="YES" 

ActiveSheet.Range("B1:B65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("CSRS").Range("B14"), Unique:=True 

請指正和分享您的建議。由於

Answer 1

我會堅持的唯一值在數組中 - 這是更快，更容易破裂 -

sub uniquearray() 
Colmz = WorksheetFunction.Match("RSDate", Sheets("RS_Report").Rows(1), 0) 

ActiveSheet.ListObjects("RS").Range.AutoFilter Field:=Colmz, Criteria1:="YES" 
Call creatary(curary, Sheets("RS_Report"), Letter(Sheets("RS_Report"), "RSDate")): Call eliminateDuplicate(curary): Call BuildArrayWithoutBlankstwo(curary): Call Alphabetically_SortArray(curary) 

For Each cell In curary 
    'do what you need to do with the unique array list 
Next cell 
end sub 

Function creatary(ary As Variant, sh As Worksheet, ltr As String) 
Dim x, y, rng As Range 
ReDim ary(0) 

Set rng = sh.Range(ltr & "2:" & ltr & sh.Range("A1000000").End(xlUp).Row).SpecialCells(xlCellTypeVisible) 

x = 0 
For Each y In rng 
    If Not Application.IsError(y) Then 
      If Not IsNumeric(y) Then 
       ary(x) = y 
      End If 
      x = x + 1 
     ReDim Preserve ary(x) 
    End If 
Next y 
End Function 

Function BuildArrayWithoutBlankstwo(ary As Variant) 
Dim AryFromRange() As Variant, AryNoBlanks() As Variant 
Dim Counter As Long, NoBlankSize As Long 

'set references and initialize up-front 
ReDim AryNoBlanks(0 To 0) 
NoBlankSize = 0 

'load the range into array 
AryFromRange = ary 

'loop through the array from the range, adding 
'to the no-blank array as we go 
For Counter = LBound(AryFromRange) To UBound(AryFromRange) 
    If ary(Counter) <> 0 Then 
     NoBlankSize = NoBlankSize + 1 
     AryNoBlanks(UBound(AryNoBlanks)) = ary(Counter) 
     ReDim Preserve AryNoBlanks(0 To UBound(AryNoBlanks) + 1) 
    End If 
Next Counter 

'remove that pesky empty array field at the end 
If UBound(AryNoBlanks) > 0 Then 
    ReDim Preserve AryNoBlanks(0 To UBound(AryNoBlanks) - 1) 
End If 

'debug for reference 
ary = AryNoBlanks 

End Function 

Function eliminateDuplicate(ary As Variant) As Variant 
Dim aryNoDup(), dupArrIndex, i, dupBool, j 


    dupArrIndex = -1 
For i = LBound(ary) To UBound(ary) 
     dupBool = False 

     For j = LBound(ary) To i 
      If ary(i) = ary(j) And Not i = j Then 
       dupBool = True 
      End If 
     Next j 

     If dupBool = False Then 
      dupArrIndex = dupArrIndex + 1 
      ReDim Preserve aryNoDup(dupArrIndex) 
      aryNoDup(dupArrIndex) = ary(i) 
     End If 
Next i 

ary = aryNoDup 
End Function 

Function Alphabetically_SortArray(ary) 

Dim myArray As Variant 
Dim x As Long, y As Long 
Dim TempTxt1 As String 
Dim TempTxt2 As String 

myArray = ary 

'Alphabetize Sheet Names in Array List 
    For x = LBound(myArray) To UBound(myArray) 
    For y = x To UBound(myArray) 
     If UCase(myArray(y)) < UCase(myArray(x)) Then 
     TempTxt1 = myArray(x) 
     TempTxt2 = myArray(y) 
     myArray(x) = TempTxt2 
     myArray(y) = TempTxt1 
     End If 
    Next y 
    Next x 

ary = myArray 
End Function 

Function Letter(oSheet As Worksheet, name As String, Optional num As Integer) 
If num = 0 Then num = 1 
Letter = Application.Match(name, oSheet.Rows(num), 0) 
Letter = Split(Cells(, Letter).Address, "$")(1) 
End Function