Question

我正在尝试创建一个宏，该宏将在名为DB的工作表中搜索单元格B5的值，并将所有结果粘贴到名为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

在Excel中查找，复制和粘贴搜索引擎

1 个答案: