VBA：按字符串变量过滤

VBA: Filter by a String Variable

提问by spaindc

Everything works in this code except for the Autofilter by the variable Sector1.

除了变量 Sector1 的 Autofilter 之外，所有内容都在此代码中工作。

The idea is that the value in Sector1 (Dropdowns sheet cell B63) can vary. In the Review tab I want to search in column D of a specific section (between RngStart and RngStop) for the string value in Sector1. When it finds it, I want to copy the information in column G to the Mkting sheet starting at A16. I know this works because if instead of sector1 I put a valid Sector (e.g., "Health") in the code below, it works.However, with this code, it just copies everything in column G, without filtering for Sector1.

这个想法是 Sector1（下拉表单元格 B63）中的值可以变化。在 Review 选项卡中，我想在特定部分（RngStart 和 RngStop 之间）的 D 列中搜索 Sector1 中的字符串值。当它找到它时，我想将 G 列中的信息复制到从 A16 开始的 Mkting 表中。我知道这是有效的，因为如果我在下面的代码中放置了一个有效的扇区（例如“健康”）而不是扇区 1，它会起作用。但是，使用此代码，它只是复制 G 列中的所有内容，而不过滤扇区 1。

Sub test()

Dim RngDest As Range
Dim RngStart As Range, RngStop As Range
Dim Sector1 As String

    Sector1 = Sheets("Dropdowns").Range("B63").Value
    With Sheets("Mkting")
        Set RngDest = .Range("A16")
    End With

    Set RngStart = Sheets("Review").Columns("A").Find("Impact Statements", , xlValues, xlPart)
    Set RngStop = Sheets("Review").Columns("A").Find("Quotes", , xlValues, xlPart)

    With Sheets("Review").Range("D" & RngStart.row & ":" & "D" & RngStop.row)
        .AutoFilter 1, Criteria1:=Sector1
        .Offset(1, 3).Copy RngDest
        .AutoFilter
    End With
End Sub

回答by David Zemens

If you only are concerned about obtaining a singlevalue (i.e., there is only one match to your AutoFilterthen just use MATCHto return the relative position of the value you're searching for:

如果您只关心获取单个值（即，只有一个匹配项，AutoFilter则仅用于MATCH返回您正在搜索的值的相对位置：

Dim foundRow as Variant
Dim rngToSearch as Range

'Define a range of column D:G, from start row to end row:
Set rngToSearch = Sheets("Review").Range("D" & RngStart.Row & ":G" & RngStop.Row)

'do a vlookup on that range
foundRow = Application.Match(Sector1, rngToSearch.Columns(1), False)

If not IsError(foundRow) Then
    rngToSearch.Cells(foundRow,1).Copy RngDest
End If

If there are multiple potential occurrences of the filtered value, then I think there are several approaches you could take, let's try which omits the header row (which would ordinarily be returned as part of the "filtered" range, unfortunately:

如果过滤值可能出现多次，那么我认为您可以采取几种方法，让我们尝试省略标题行（不幸的是，它通常会作为“过滤”范围的一部分返回：

Dim rngToSearch as Range
Dim copyRange As Range

Set rngToSearch = Sheets("Review").Range("D" & RngStart.Row & ":G" & RngStop.Row)
'Get a single column range representing column G:
Set copyRange = rngToSearch.Offset(1, 3).Resize(rngToSearch.Rows.Count - 1, 1)

rngToSearch.AutoFilter 1, Criteria1:=Sector1

copyRange.SpecialCells(xlCellTypevisible).Copy rngDest

rngToSearch.AutoFilter 'Turn off the filter   

To omit blanks from column G, do something like this immediately afteryou apply the first autofilter, add another one for column G:

要从 G 列中省略空白，请在应用第一个自动过滤器后立即执行以下操作，为 G 列添加另一个：

rngToSearch.AutoFilter 4, Criteria1:="<>", Operator:=xlAnd

Here is my test version(using slightly different range/etc.), output to F2:

这是我的测试版本（使用略有不同的范围/等），输出到 F2：

Sub test()
Dim rngToSearch As Range
Set rngToSearch = Range("A1:D8")

rngToSearch.AutoFilter 1, Criteria1:=2

rngToSearch.AutoFilter 4, Criteria1:="<>", Operator:=xlAnd

Dim copyRange As Range
Set copyRange = rngToSearch.Offset(1, 3).Resize(rngToSearch.Rows.Count - 1, 1)

If rngToSearch.SpecialCells(xlCellTypeVisible).Rows > 1 Then
    copyRange.SpecialCells(xlCellTypeVisible).Copy Range("F2")
End If

rngToSearch.AutoFilter

End Sub

回答by spaindc

I am adding code to David's great answer to deal with the case where there what you are sorting on does not appear in your RngToSeach - that is, Sector1 is not in your range. David, I put together a lot of other things you have helped me with to come up with this. Thank you so much for your help!

我正在向 David 的出色答案添加代码，以处理您正在排序的内容未出现在您的 RngToSeach 中的情况——也就是说，Sector1 不在您的范围内。大卫，我把你帮助我提出的很多其他东西放在一起。非常感谢你的帮助！

Sub test()

子测试()

Dim RngToSearch As Range
Dim RngDest As Range
Dim RngStart As Range, RngStop As Range
Dim copyRng As Range
Dim Sector1 As String
Dim foundRow As Variant

With Sheets("Mkting")
        Set RngDest = .Range("A80")
End With

Set RngStart = Sheets("Review").Columns("A").Find("Impact Statements", , xlValues, xlPart)
Set RngStop = Sheets("Review").Columns("A").Find("Quotes", , xlValues, xlPart)

Set RngToSearch = Sheets("Review").Range("D" & RngStart.row & ":G" & RngStop.row)
Set copyRng = RngToSearch.Offset(1, 3).Resize(RngToSearch.Rows.Count - 1, 1)

RngToSearch.AutoFilter 1, Criteria1:=Sector1
RngToSearch.AutoFilter 4, Criteria1:="<>"
If RngToSearch.SpecialCells(xlCellTypeVisible).Rows.Count > 1 Then
    copyRng.SpecialCells(xlCellTypeVisible).Copy RngDest
ElseIf RngToSearch.SpecialCells(xlCellTypeVisible).Rows.Count = 1 Then
    foundRow = Sheets("Review").Application.Match(Sector1, RngToSearch.Columns(1), False)
    If Not IsError(foundRow) Then
      RngToSearch.Cells(foundRow, 4).Copy RngDest
    End If
End If
RngToSearch.AutoFilter
End Sub