VBA：按字符串变量过滤

Question

除了变量Sector1的自动过滤器之外，所有内容都适用于此代码。

想法是Sector1（下拉列表单元格B63）中的值可以变化。在Review选项卡中，我想在特定部分的列D（在RngStart和RngStop之间）中搜索Sector1中的字符串值。当它找到它时，我想将G列中的信息复制到A16开始的Mkting表中。我知道这是有效的，因为如果我在下面的代码中放置了一个有效的Sector（例如，＆＃34; Health＆＃34;）而不是sector1，那么它可以工作。但是，使用这个代码，它只是复制G列中的所有内容，而不过滤对于Sector1。

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

Answer 1

如果您只关心获取单个值（即，只有一个匹配到您的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

如果有多个可能出现的过滤值，那么我认为您可以采取多种方法，让我们尝试省略标题行（通常会将其作为＆＃34的一部分返回;不幸的是，过滤了＆＃34;范围：

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   

要忽略G列中的空白，请在应用第一个自动过滤后立即执行此类之类的操作，为G列添加另一个

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

这是我的测试版本（使用稍微不同的范围/等），输出到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

Answer 2

我正在为David提供一个很好的答案来处理你正在排序的东西没有出现在你的RngToSeach中的情况 - 也就是说，Sector1不在你的范围内。大卫，我把你帮助我的很多其他东西放在一起来想出这个。非常感谢你的帮助！

子测试（）

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