搜索单元格中匹配的值，然后复制

Question

我想用VBA代码过滤Excel表。

A1，B1，C1是标题

• A列=全部（A2：xx）
• B列=搜索内容（B2：xx）
• 列C =（C2：xx）

应在B列中的所有内容中搜索A列，如果找到一个或多个，则应写入C列。

我尝试了以下方法。

Sheets("Tabelle2").Range("A2:A2000").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("B2:B2000"), CopyToRange:=Range("C2:C2000")

以便将A列中的所有内容复制到C列，但不与B列进行比较。

我该如何做？

Answer 1

我建议您使用帮助列，然后无需进行VBA编码即可轻松实现。

帮助列公式：

=IF(ISERROR(MATCH(A2,$B$2:$B$9,0)),ROW(),"")

然后使用以下公式提取未备份的服务器列表。

=IFERROR(INDEX($A$2:$A$31,SMALL($D$2:$D$31,ROW(1:1))),"")

See the file

Answer 2

您必须包括标题。

Sub test()
    Dim rngDB As Range
    Dim rngCria As Range
    Dim rngTo As Range
    Dim Ws As Worksheet

    Set Ws = Sheets("Tabelle2")

    With Ws
        Set rngDB = .Range("a1:a2000")
        Set rngCria = .Range("B1", .Range("b" & Rows.Count).End(xlUp))
        Set rngTo = .Range("c1")
    End With
    rngDB.AdvancedFilter xlFilterCopy, rngCria, rngTo


End Sub

Answer 3

Option Explicit
Sub ListMatches()
    Dim rngColumnA As Range, celColumnB As Range, rngColumnB As Range
    Set rngColumnA = Range("A2:A" & Range("A1000000").End(xlUp).Row)
    Set rngColumnB = Range("B2:B" & Range("B1000000").End(xlUp).Row)
    For Each celColumnB In rngColumnB
        If Not rngColumnA.Find(What:=celColumnB) Is Nothing Then Range("C" & Range("C1000000").End(xlUp).Row + 1) = celColumnB.Value
    Next celColumnB
End Sub

Answer 4

在您的应用程序中使用收藏夹可能会更快：

Sub ListMatches()
    Dim R1 As Range, R2 As Range, R As Range, Nc As New Collection
    Set R1 = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
    Set R2 = Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
    On Error Resume Next
    For Each R In R1
        Nc.Add R.Value, R.Value
    Next R
    For Each R In R2
        Err = 0
        Nc.Add R.Value, R.Value, 1
        If Err = 0 Then
            Range("C" & Range("C" & Rows.Count).End(xlUp).Row + 1) = R.Value
            Nc.Remove 1
        End If
    Next R
    On Error GoTo 0
End Sub