过滤一列，返回不同列的所有相关结果

我一直在想如何做到这一点，不能完全弄清楚。 前提如下。 我需要在COLUMN B上过滤，之后我需要使用过滤后的COLUMN A的返回结果来过滤所有的结果。 如果这是令人困惑，我试图“画出”下面…

COL A | COL B | cat | 44 | cat | 476 | cat | 19 | dog | 11 | dog | 12 | bird | 44 | bird | 99 | bird | 4556 | 

所以如果我在B列过滤44，我只会得到两个'44'行（cat | 44和bird | 44）。 相反 ，我想以某种方式得到所有的猫行和所有的鸟行，因为44与这两个“A”types相关联。

 COL A | COL B | cat | 44 | cat | 476 | cat | 19 | bird | 44 | bird | 99 | bird | 4556 | 

你有没有做过这个？ 我的想法是最初将未改变的纸张复制到新的纸张2，应用filter并将返回的列A结果复制到新的纸张3，使用返回的列A结果在纸张3在sheet2列A上执行自动filter但是，可以有数百个filter，这在VBA中是一个非常手动的过程。

如果需要，我很乐意添加更多细节。

Answer 1

您可以避免使用一个或多个变体数组的AutoFilter方法和Range.SpecialCells方法 。

 Option Explicit Sub cats_and_birds() Dim crit As Long Dim i As Long, j As Long, iCols As Long Dim arr1 As Variant Static dict As Object '<~~ faster second time around this way 'create and configure the static dictionary If dict Is Nothing Then _ Set dict = CreateObject("Scripting.Dictionary") dict.RemoveAll dict.CompareMode = vbTextCompare 'number of columns to transfer from column A iCols = 3 'set filter criteria for column 2 within range crit = 44 With Worksheets("Sheet1") 'assign raw values arr1 = .Range(.Cells(2, 1), Cells(.Rows.Count, iCols).End(xlUp)).Value2 'show the data array limits in the Immediate window 'delete this or comment it after the routine works Debug.Print LBound(arr1, 1) & " to " & UBound(arr1, 1) Debug.Print LBound(arr1, 2) & " to " & UBound(arr1, 2) 'iterate through the 'rows' of the array and compare column 2 For i = LBound(arr1, 1) To UBound(arr1, 1) 'add/oversrite the pet species as key If arr1(i, 2) = crit Then _ dict(arr1(i, 1)) = 0 'if pet species in key, transfer information If dict.exists(arr1(i, 1)) Then 'iterate through the columns backwards to maintain row For j = UBound(arr1, 2) To LBound(arr1, 2) Step -1 .Cells(.Rows.Count, "Z").End(xlUp).Offset(1, j - 1) = arr1(i, j) Next j End If Next i End With End Sub 

这对两个arrays来说实际上会更好。 第二个接收结果，然后批量传输信息，但也有一个（更小）的罚款，因为redim'arrays保留（和转置）。 对于小的（<10K），这可能只是稍微长一点的处理。 对于<100行的过滤信息，您可能无法使用特殊工具来测量差异。

将字典对象变暗为静态缩短第二次加载时间，因为您不必重新创build对象。 虽然我更喜欢将Microsoft脚本运行时添加到工具►引用，并使用dim dict as new scripting.dictionary不是每个人都喜欢，所以我会发布这与CreateObject和昏暗的字典静态。

Answer 2

您可以将此例程作为模型：适用于Sheet1 ，在列B查找44 ，然后显示与列A相匹配的行

 Sub filterBthenA() Sheet1.UsedRange.Columns("B").AutoFilter 1, 44 '<-- Filter Sheet1 col B by value 44 Dim cel As Range, dict As Object: Set dict = CreateObject("Scripting.Dictionary") For Each cel In Sheet1.UsedRange.Columns("A").SpecialCells(xlCellTypeVisible) dict(cel.Value) = 0 Next Sheet1.AutoFilterMode = False Sheet1.UsedRange.Columns("A").AutoFilter 1, dict.Keys, xlFilterValues End Sub