Поиск ячейки для соответствующего значения, а затем скопировать

Question

Я бы хотел отфильтровать таблицу Excel с помощью кода VBA.

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

Использование коллекции может быть еще быстрее в вашем приложении:

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

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

Я предлагаю вам использовать столбец помощи, тогда вы можете легко сделать это без 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))),"")

См. файл