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

Question

I would be very grateful if someone can help me with the following:

I want to search for a text (using Textbox) in a very large database. (for example searching for: Iron). The results I'm expecting would be like the following: "Red Iron", "Iron grey", "A very long iron" + copying the entire rows to another sheet (with the textbox name) and find the lowest price which is in range (D2:J). D1, E1, F1, G1, H1, I1, J1 are the suppliers. If it's possible I want to show the supplier name and the lowest price in a msgbox.

I want to search in range A:A.

Can anybody help me with this?

Many thanks, N.

Answer 1

Couple things to help you start, in case you've not tried any coding yourself...

.1) You can give yourself a Userform to input the desired term (you should be able to make the Userform yourself). Make sure to save that term outside of the code, so you can carry it through (in case you write multiple macros for each part):

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

Sub NameOfNextSub()

.2) I haven't played much with the Find function, but I have done something similar to what you're wanting where I loop and match. If there's a match, it pastes the row matched within to the end of another sheet

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"

Google delete empty rows... you should gets tons of hits, doing it different ways; pick what feels best for you. Make sure it runs on Sheet2.

That's a pretty lazy way of doing it, but it will work.

.3) Filter Sheet2 based on whatever column has cost, xlAscending. Again, quick google on that. Will look something like:

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

.4) Since you know your lowest price will be in the top row, and you know the column, you can have a messagebox show up to display what's in that cell:

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

That should get you ready to code up what you want, in 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

End Sub `

Answer 3

I tried another coding. This one is identifying the text i'm looking for a copy and paste to an existing sheet. Clear contents at the beginning of the macro.

`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  

What i'm trying to do next, is to compare values from columns D, I, N and R, the lowest to go yellow and the biggest value to go red, for each item. Can anybody help?

Many thanks! N.