搜索范圍內的文本並顯示包含該文本的所有行 - 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。