Поиск (Ctrl + F) нескольких слов одновременно в Excel

Question

Я работаю над файлом Excel, и у меня есть список слов, которые мне нужно найти, и, если я его найду, мне нужно выделить его столбец.

Я хочу использовать CTRL + F, но могутолько скопируйте и вставьте одно слово за раз, поэтому я бродил, если есть способ автоматизировать эту задачу с помощью VBA или условного форматирования.

Я смотрел в Интернете, но решения не подходят мнепроблема.

Answer 1

Я нашел это на mrexcel.com ( Найти записи и поместить в сводный лист ) и быстро его изменить (спасибо BrianB).

Смотрите, как вкладки названы так, как они названы в коде. Это просто, чтобы помочь быстро и показать вам одну сторону, это не очень хорошо отредактировано или прокомментировано мной.

Sub FindRecords()
    Dim FromSheet As Worksheet
    Dim FromRow As Long
    Dim ToSheet As Worksheet
    Dim ToRow As Long
    Dim FindThis As Variant
    Dim FoundCell As Object
    '---------------------------------------------------
    Application.Calculation = xlCalculationManual
    Set FromSheet = ThisWorkbook.Worksheets("DataSheet")
    Set ToSheet = ThisWorkbook.Worksheets("Summary")
    ToRow = ThisWorkbook.Worksheets("Summary").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
    '---------------------------------------------------
    '- get user input
    FindThis = InputBox("Please enter data to find : ")
    If FindThis = "" Then End ' trap Cancel
    '---------------------------------------------------
    '- clear summary for new data
    'ToSheet.Cells.ClearContents
    '---------------------------------------------------
    ' FIND DATA
    '-
    With FromSheet.Cells
        Set FoundCell = .Find(FindThis, LookIn:=xlValues)
        If Not FoundCell Is Nothing Then
            FirstAddress = FoundCell.Address
            '------------------------------------------
            '- copy data to summary
            'Do
                FromRow = FoundCell.Row
                ToSheet.Cells(ToRow, 1).Value = _
                        FromSheet.Cells(FromRow, 1).Value
                ToSheet.Cells(ToRow, 2).Value = _
                        FromSheet.Cells(FromRow, 2).Value
                ToSheet.Cells(ToRow, 3).Value = _
                        FromSheet.Cells(FromRow, 3).Value
                ToRow = ToRow + 1
                'Set FoundCell = .FindNext(FoundCell)
            'Loop While Not FoundCell Is Nothing And _
             '   FoundCell.Address <> FirstAddress
            '------------------------------------------
        End If
    End With
    MsgBox ("Done.")
    Application.Calculation = xlCalculationAutomatic
    FindRecords
End Sub