Question

我的任务是从工作簿中的每月工作表中提取两行特定的数据。

使用MyVal和搜索框的当前代码仅与一次搜索兼容。如何更改代码和＆amp;搜索框功能与多个搜索兼容？

当前代码如下所示：

    Sub Set_Hyper()
     '   Object variables
    Dim wks As Excel.Worksheet
    Dim rCell As Excel.Range
    Dim fFirst As String
     '   {i} will act as our counter
    Dim i As Long
     '   Use an input box to type in the search criteria
    Dim MyVal As String
    MyVal = InputBox("What are you searching for", "Search-Box", "")
     '   if we don't have anything entered, then exit the procedure
    If MyVal = "" Then Exit Sub
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

     '       Add a heading to the sheet with the specified search value
    With Cells(1, 1)
        .Value = "Found " & MyVal & " in the Link below:"
        .EntireColumn.AutoFit
        .HorizontalAlignment = xlCenter
    End With
    i = 2
     '       Begin looping:
     '       We are checking all the Worksheets in the Workbook
    For Each wks In ActiveWorkbook.Worksheets
         If wks.Name <> "Data" Then

         '       We are checking all cells, we don't need the SpecialCells method
         '       the Find method is fast enough
            With wks.Range("A:A")
             '           Using the find method is faster:
             '           Here we are checking column "A" that only have {myVal} explicitly

                Set rCell = .Find(MyVal, , , xlWhole, xlByColumns, xlNext, False)
             '           If something is found, then we keep going
                If Not rCell Is Nothing Then
                 '               Store the first address
                    fFirst = rCell.Address
                    Do
                     '                   Link to each cell with an occurence of {MyVal}
                        rCell.Hyperlinks.Add Cells(i, 1), "", "'" & wks.Name & "'!" & rCell.Address
                        wks.Range("B" & rCell.Row & ":R" & rCell.Row).Copy Destination:=Cells(i, 2)

                        Set rCell = .FindNext(rCell)
                        i = i + 1 'Increment our counter
                    Loop While Not rCell Is Nothing And rCell.Address <> fFirst
                End If
            End With
         End If
    Next wks
     '   Explicitly clear memory
    Set rCell = Nothing
     '   If no matches were found, let the user know
    If i = 2 Then
        MsgBox "The value {" & MyVal & "} was not found on any sheet", 64, "No Matches"
        Cells(1, 1).Value = ""
    End If
     '   Reset application settings
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
   End Sub

Answer 1

我在想你能做的是使用以下控件创建一个UserForm：

文本框列表框用于向列表框添加文本的按钮另一个运行VBA的按钮

文本框可以保存搜索字符串。单击按钮执行以下操作时，您可以创建一个事件：

1）将文本框中的文本添加到列表框中。查找AddItem方法来执行此操作。 2）清除文本框内容，以便添加新值。

添加完成后，您可以在代码周围添加另一个for循环，以浏览添加到列表框中的每个项目。这样，您可以根据添加的内容进行多次搜索。

希望这有助于：）

VBA工作表数据提取以搜索多个值

1 个答案: