通过字符串的关键字部分查找，选择所有单元格(整行)，将范围复制到另一个纸张并打印

Question

我是VBA的新手，并且已经在此处找到了几乎没有类似的问题，这两者都相似，但我想让搜索不舒适的人对Excel经历的人们感到舒适或相对较长的产品目录（〜1500种不同的产品），我为报价工作的公司。

工作簿有3张纸，其中1页仅包含一个问候。搜索功能的描述。我插入了一个链接到单元格（在我的情况D24）的文本框（活动X）和一个称为"搜索"的搜索按钮（命令按钮）。在第3页中，我在B列中有产品列表：。

在第2页中，我有一个标题行，带有来自Sheep3的所有列标题，我用它来粘贴结果（清洁前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

您需要更改搜索范围