Найти, скопировать и вставить поисковую систему в Excel

Question

Я пытаюсь создать макрос, который будет искать значение ячейки B5 в листе, называемом DB, и вставлять все результаты в лист под названием Research. Идея состоит в том, чтобы скопировать каждую строку, соответствующую ключевому слову, и вставить их, начиная с B11 в листе базы данных.

Я не знаю, если это возможно, но заблаговременно за ваше время.

Answer 1

Sub CreateList()

Application.ScreenUpdating = False 
Application.Calculation = xlCalculationManual 

Dim LastRow As Long 
Dim I As Integer 
Dim J As Integer 
Dim srchtxt As String 
Dim celltxt As String 



'Determines last row of database worksheet to know what range to loop through 
LastRow = Worksheets("DB").Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 

'Gets the text or value to be searched 
srchtxt = Worksheets("SearchWS").Range("B5") '***Change cell to search 

'Clear research sheet, the destination sheet 
Worksheets("Research").Cells.Clear 

'Activate DataBase sheet 
Worksheets("DB").Activate 

'Loops through and copies all rows with desired value or text, pasting them in the research sheet. j keeps track of the next empty row. 
'The InStr and UCase ensure capitalization doesn't cause a problem. You may not want this if you need exact match. 
J = 2 '*** Change the first row to paste 
For I = 2 To LastRow 
    celltxt = Worksheets("DB").Cells(I, 1).Text 'Gets the value from the DB worksheet ***Change the column to seach in 
    If InStr(1, UCase(celltxt), UCase(srchtxt)) Then 'Compares it to the specified text, B5 in this case 
    Worksheets("DB").Range(Cells(I, 1), Cells(I, 2)).Copy Destination:=Worksheets("Research").Cells(J, 1) 
    'Copies the range above. ***Change the range to copy, from 1 to 2 
    J = J + 1 
End If 
Next I 'Loops through 

Application.ScreenUpdating = True 
Application.Calculation = xlCalculationAutomatic 

End Sub