Question

我有一个要求在哪里，我需要先使用自动过滤器来过滤数据然后再使用高级过滤器来获取Unique值。但是高级过滤器并不单独采用自动过滤值。我如何一起使用它们？

这是我的代码，

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

Excel VBA - 自动过滤器和高级过滤器使用错误

1 个答案: