在Excel中查找，複製和粘貼搜索引擎

Question

我試圖創建一個宏來搜索名爲DB的工作表中的單元格B5的值，並將所有結果粘貼到名爲Research的工作表中。我們的想法是複製與關鍵字匹配的每一行，並將它們從數據庫表中的B11開始粘貼。

我不知道是否有可能，但提前感謝您的時間。

Answer 1

子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 

結束子