Поиск по ключевой части части строки, выбор всех ячеек (целых строк), скопируйте диапазон на другой лист и распечатайте его

Question

Я новичок в VBA и уже нашел несколько похожих ранее вопросов, как похожих, так и совершенно разных поскольку я хотел бы сделать поиск удобным для людей, не имеющих опыта работы с excel или относительно длинным каталогом продуктов (~ 1500 различных продуктов), компании, в которой я работаю для предложений.

В книге есть 3 листа, в которых Лист 1 содержит только приветствие, вкл. описание функции поиска. Я вставил текстовое поле (активное x), которое связано с ячейкой (в моем случае D24) и кнопкой поиска (кнопка команды) под названием «Поиск». В листе 3 у меня есть список продуктов в столбцах B: E, называемый «product_category», «sub_category», «product_number», «Product_name» и «product_specification» (столбец A называется «Sequent_Number» и в данном случае не имеет значения) ,

В листе 2 У меня есть строка заголовка со всеми заголовками столбцов из Sheet3, и я использую ее для вставки результатов (очистка первых 200 строк, как в некоторых категориях, чуть более 100 продуктов) и печать.

Есть 2 проблемы решить:

• Как я могу, расширить область поиска для всех столбцов,

• Как я могу найти в части строки (а не только точное совпадение) как текущий.

Текущий код:

Sub Search_ProductName_by_Keyword() 
Dim ProductName As String 
Dim Finalrow As String 
Dim i As Integer 
ProductName= Sheet1.Range("D24").Value 
Sheet2.Range("B6: E200").ClearContents 
Sheet3.Select 
Finalrow = Cells(Rows.count, 1).End(xlUp).Row 
For i = 2 To finalrow 
If Cells(i, 5) = ProductName Then 
Range(Cells(i, 4), Cells(i, 7)).Copy 
Sheet2.Select 
Range("B200").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues 
Sheet3.Select 
End If 
Next i 
Sheet1.Select 
Range("d24").Select 
End Sub 

Я открыт для любых идей и предложений. Спасибо заранее!

Answer 1

вы можете использовать AutoFilter():

Option Explicit 

Sub main() 
    Dim ProductName As String 

    ProductName = Sheet1.Range("D24").Value 
    Sheet2.Range("B5: E200").ClearContents '<--| clear headers too, since they will be readded from AutoFilter selected cells 

    With Sheet3 
     With .Range("E1", .Cells(.Rows.count, "E").End(xlUp)) '<--| reference its columns E cells from row 1 down to last not empty cell 
      .AutoFilter Field:=1, Criteria1:="*" & ProductName & "*" '<--| filter it on its 1st (and only) column with "*'ProductName'* values 
      If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then '<--| if any filtered cells other than headers 
       Intersect(.Parent.Range("B:E"), .SpecialCells(xlCellTypeVisible).EntireRow).Copy '<-- copy filtered cells, headers included 
       Sheet2.Range("B5").PasteSpecial xlPasteValues '<--| paste values only from Sheet2 cell "B5" 
      End If 
     End With 
     .AutoFilterMode = False '<--| remove AutoFilter and show all rows back 
    End With 

End Sub 

Answer 2

Sub test() 

Dim r As Range 
Dim strProductName As String 

strProductName = "DEF" 

For i = 2 To 10 

Set r = Range(Cells(i, 5), Cells(i, 10)).Find(What:=strProductName, After:=Cells(i, 5), _ 
    LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, _ 
    SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) 

If Not r Is Nothing Then Debug.Print i 

Next i 

End Sub 

Вам нужно изменить диапазон поиска