Excel VBA - 自动过滤器和高级过滤器使用错误 [英] Excel VBA - Auto FIlter and Advanced filter usage error

问题描述

我有一个要求，我需要使用自动过滤器首先过滤数据，然后使用高级过滤器来获取唯一值。但高级过滤器不会单独使用自动过滤的值。如何一起使用？

这里是我的代码，

  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 
  

请更正我并分享您的建议。谢谢

解决方案

我将把数组中唯一的值保留下来 - 它的速度更快，并且不太可能中断 -

  sub uniquearray（）
 Colmz = WorksheetFunction.Match（RSDate，Sheets（RS_Report）。Rows（1），0） 
 
 ActiveSheet.ListObjects（RS）。Range.AutoFilter字段：= Colmz，Criteria1：=YES
调用创建者（curary，Sheets（RS_Report），Letter（Sheets （RS_Report），RSDate））：Call eliminationDuplicate（curary）：Call BuildArrayWithoutBlankstwo（curary）：Call Alphabet_SortArray（curary）
 
对于每个单元格在
'需要使用唯一的数组列表
下一个单元格
 end sub 
 
函数creatary（ary As Variant，sh As Worksheet，ltr As String）
 Dim x， y，rng As Range 
 ReDim ary（0）
 
设置rng = sh.Range（ltr&2：& ltr& sh.Range（A1000000）。 End（xlUp）.Row）.SpecialCells（xlCellTypeVisible）
 
x = 0 
对于每个y在rng 
如果不适用ation.IsError（y）Then 
如果不是IsNumeric（y）然后
 ary（x）= y 
 End If 
x = x + 1 
 ReDim Preserve ary x）
 End If 
 Next y 
结束函数
 
函数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到0）
 NoBlankSize = 0 
 
'将范围加载到数组
 AryFromRange = ary 
 
'循环遍历该范围的数组，在$空白数组中添加
' 
对于Counter = LBound（AryFromRange）到UBound（AryFromRange）
如果ary（Counter）<> 0然后
 NoBlankSize = NoBlankSize + 1 
 AryNoBlanks（UBound（AryNoBlanks））= ary（Counter）
 ReDim保留AryNoBlanks（0到UBound（AryNoBlanks）+ 1）
结束If 
下一个计数器
 
'结束时删除那个讨厌的空数组字段
如果UBound（AryNoBlanks）> 0然后
 ReDim保存AryNoBlanks（0到UBound（AryNoBlanks） -  1）
结束如果
 
'调试参考
 ary = AryNoBlanks 
 
结束函数
 
函数eliminationDuplicate（ary As Variant）As Variant 
 Dim aryNoDup（），dupArrIndex，i，dupBool，j 
 
 
 dupArrIndex = -1 
对于i = LBound（ary）到UBound（ary）
 dupBool = False 
 
对于j = LBound（ary）To i 
如果ary i）= ary（j）而不是i = j然后
 dupBool = True 
结束如果
下一个j 
 
如果dupBool = False然后
 dupArrIndex = dupArrIndex + 1 
 ReDim保存aryNoDup（dupArrIndex）
 aryNoDup（dupArrIndex）= ary（i）
 End If 
 Next i 
 
 ary = aryNoDup 
结束函数
 
函数Alphabet_SortArray（ary）
 
 Dim myArray As Variant 
 Dim x As Long，y As Long 
 Dim TempTxt1 As String 
 Dim TempTxt2 As Str 
 
 myArray = ary 
 
'数组列表中的字母顺序表名称
对于x = LBound（myArray）到UBound（myArray）
对于y = x到UBound（myArray）
如果UCase（myArray（y））< UCase（myArray（x））然后
 TempTxt1 = myArray（x）
 TempTxt2 = myArray（y）
 myArray（x）= TempTxt2 
 myArray（y）= TempTxt1 
结束如果
下一个y 
下一个x 
 
 ary = myArray 
结束函数
 
函数函（oSheet As Worksheet，name As String，可选num As Integer）
如果num = 0则num = 1 
 Letter = Application.Match（name，oSheet.Rows（num），0）
 Letter = Split ，Letter）地址，$）（1）
结束功能
  

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

解决方案

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

这篇关于Excel VBA - 自动过滤器和高级过滤器使用错误的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！