Excel VBA - Auto FIlter and Advanced filter usage error

问题

I have a requirement where in, I need to use the auto filter to filter the data first and then am using the advanced filter to get the Unique values alone. But the advanced filter doesn't take the auto filtered value alone. How do I use them together?

Here goes my code,

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

Kindly correct me and share your suggestions. Thanks

回答1:

I would stick the unique values in an array - it's faster and less likely to break -

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

来源：https://stackoverflow.com/questions/43276259/excel-vba-auto-filter-and-advanced-filter-usage-error

标签

excel

vba

excel-vba