搜索范围内的文本并显示包含该文本的所有行 - VBA

Question

如果有人可以帮助我解决以下问题，我将不胜感激：

我想在一个非常大的数据库中搜索文本（使用文本框）。 （例如搜索：Iron）。 我期望的结果如下：“红铁”、“铁灰”、“一个很长的铁”+ 将整行复制到另一张纸（带有文本框名称）并找到其中的最低价格范围 (D2:J)。 D1、E1、F1、G1、H1、I1、J1是供应商。 如果可能，我想在 msgbox 中显示供应商名称和最低价格。

我想在 A:A 范围内搜索。

有人可以帮我解决这个问题吗？

非常感谢，N。

Answer 1

一些事情可以帮助您开始，以防您自己没有尝试过任何编码......

.1）您可以给自己一个用户表单来输入所需的术语（您应该能够自己制作用户表单）。 确保将该术语保存在代码之外，以便您可以执行它（以防您为每个部分编写多个宏）：

Public burp as Text
Sub 
    Set burp = Userform(1).Textbox(1).Value 'Will need to tweak
End Sub

Sub NameOfNextSub()

.2) 我没怎么玩过 Find 功能，但我做了一些类似于你想要的循环和匹配的东西。 如果匹配，则将匹配的行粘贴到另一张纸的末尾

Dim LR as Long
LR = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row

For i = 1 to LR
    If IsError(WorkSheetFunction.Match(*burp*,cells(i,2)),0)>0 Then
        Sheets("Sheet1").Row(i).Copy
        Sheets("Sheet2").Row(i).PasteSpecial xlPasteValues
        Else:
        End If
Next i
Delete_Empty_Rows 'runs macro named "Delete_Empty_Rows"

谷歌删除空行......你应该得到大量的点击，用不同的方式； 选择最适合你的。 确保它在 Sheet2 上运行。

这是一种非常懒惰的方法，但它会起作用。

.3) 根据任何列的成本 xlAscending 过滤 Sheet2。 再次，快速谷歌。 看起来像：

Columns("A:C").Sort key1:=Range("C2"), _
  order1:=xlAscending, header:=xlNo

.4) 由于您知道最低价格将在顶行，并且您知道列，因此您可以显示一个消息框以显示该单元格中的内容：

MsgBox "Lowest price: "&Cells(1,4)

这应该让您准备好在 VBA 中编写您想要的代码。

Answer 2

`Private Sub SearchCommandButton_Click()
`Dim searchitem As Variant
`Dim lr As Long
`Dim WSNew As Worksheet
`Dim sheetname As String

`Set searchitem = SearchUserForm.TextBox1.Value
`lr = Cells(Sheets("GC").Rows.Count, 1).End(xlUp).Row
`For i = 1 To lr
`If IsError(WorksheetFunction.Match(searchitem, Cells(i, 2)), 0) > 0 Then
`Sheets("GC").Row(i).Copy
`Else
`Set WSNew = Worksheets.Add(After:=Sheets(ActiveSheet.Index))

    sheetname = searchitem

    On Error Resume Next

    WSNew.Name = sheetname
    If Err.Number > 0 Then
        MsgBox "We cannot match the search: " & WSNew.Name & _
             " Please try again" & _
             " Sheet already exist!" & _
             " The sheet name cannot contain this!"
        Err.Clear
    End If
    On Error GoTo 0

    With WSNew.Range("A1")

        .PasteSpecial Paste:=8
        .PasteSpecial xlPasteValues
        .PasteSpecial xlPasteFormats
        Application.CutCopyMode = False
        .Select
    End With

End If

结束子`

Answer 3

我尝试了另一种编码。 这是识别我正在寻找的文本，复制并粘贴到现有工作表中。 清除宏开头的内容。

`Private Sub SearchCommandButton_Click()
Dim rFind As Range
Dim rCopy As Range
Dim strSearch As String
Dim sFirstAddress As String
Dim destsh As Worksheet

Sheets("comparelist").Activate
Sheets("comparelist").Range("A2:AA200").ClearContents
strSearch = TextBox1.Value
Set rCopy = Nothing

Application.ScreenUpdating = False

With Sheets("GC").Columns("A:A")
Set rFind = .Find(strSearch, LookIn:=xlValues, Lookat:=xlPart,SearchDirection:=xlNext, MatchCase:=False)
If Not rFind Is Nothing Then sFirstAddress = rFind.Address
    Do
        If rCopy Is Nothing Then
            Set rCopy = rFind
        Else
            Set rCopy = Application.Union(rCopy, rFind)
        End If
        Set rFind = .FindNext(rFind)
    Loop While Not rFind Is Nothing And rFind.Address <> sFirstAddress

    rCopy.EntireRow.Copy
    Sheets("comparelist").Activate
    Sheets("comparelist").Range("A2").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Application.ScreenUpdating = True
Unload Me
Sheets("comparelist").Range("A1").Select

End If
End With
End Sub  

我接下来要做的是比较 D、I、N 和 R 列中的值，最低值变为黄色，最大值变为红色，对于每个项目。 有人可以帮忙吗？

非常感谢！ N。