按字符串的关键字部分查找 select 所有单元格（整行），将范围复制到另一个 sheet 并打印

Question

我是 VBA 的新手，已经发现了几个以前在这里回答过的类似问题，既相似又完全不同，因为我想让没有经验的人也能轻松搜索 excel 或我工作的公司提供的相对较长的产品目录（~1500 种不同的产品）。

工作簿有 3 张，其中 Sheet 1 张仅包含问候语。搜索功能的描述。我插入了一个链接到单元格（在我的例子中是 D24）的文本框（活动 x）和一个名为 "Search" 的搜索按钮（命令按钮）。在 Sheet 3 中，我在列 B:E 中列出了名为 "product_category"、"sub_category"、"product_number"、"Product_name" 和 "product_specification" 的产品列表（A 列称为 "Sequent_Number"，在这种情况下不相关）。

在 Sheet 2 中，我有一个标题行，其中包含 Sheet3 中的所有列 headers，我用它来粘贴结果（清理前 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

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

您需要更改搜索范围

Answer 2

您可能想使用 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

按字符串的关键字部分查找 select 所有单元格（整行），将范围复制到另一个 sheet 并打印

Finding by Keyword part of string, select all cells (whole rows), copy the range to another sheet and print it

vba

excel-2007