在excel VBA中搜索多个不同的字符串

Question

我试图让用户搜索多达 6 种不同类型的字符串（文本）。但是我已经尝试了最多 2 次，

问题

但我的代码只正确执行第一个搜索。但是，在第一个字符串之后的任何搜索都没有达到目标。

目标

代码的目标是在指定行中查找字符串，然后在该列中搜索大于零的值，如果是则复制整行。

Private Sub btnUpdateEntry_Click()

Dim StringToFind As String
Dim SringToFind2 As String
Dim i As Range
Dim cell As Range

StringToFind = Application.InputBox("Enter string to find", "Find string")
StringToFind2 = Application.InputBox("Enter string to find", "Find string")

With Worksheets("Skills Matrix")
    Set cell = .Rows(1).Find(What:=StringToFind, LookAt:=xlWhole, _
                             MatchCase:=False, SearchFormat:=False)

    If Not cell Is Nothing Then
        For Each i In .Range(cell.Offset(1), .Cells(.Rows.Count, cell.Column).End(xlUp))
            If IsNumeric(i.Value) Then
                If i.Value > 0 Then
                    i.EntireRow.Copy
                    Sheets("Data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
                End If
            End If
        Next i
    Else
        Worksheets("Data").Activate
        MsgBox "String not found"
    End If
End With

End Sub

谢谢

Answer 1

不要将要搜索的字符串存储在单独的变量中，而是将它们放入数组中。您可以使用 For Each 循环遍历数组，因此非常适合：

Private Sub btnUpdateEntry_Click()

Dim StringsToFind(1 to 6) As String
Dim StringToFind as Variant 'Array's demand that their elements be declared as variants or objects, but we know that the element will be a string
Dim i As Range
Dim cell As Range

'Iterate through your empty array and ask for values:
For Each StringToFind in StringsToFind
    StringsToFind(StringToFind) = Application.InputBox("Enter string to find", "Find string")
Next StringToFind


With Worksheets("Skills Matrix")

    'Now iterate again to search:
    For Each StringToFind in StringsToFinds
        Set cell = .Rows(1).Find(What:=StringToFind, LookAt:=xlWhole, _
                                 MatchCase:=False, SearchFormat:=False)

        If Not cell Is Nothing Then
            For Each i In .Range(cell.Offset(1), .Cells(.Rows.Count, cell.Column).End(xlUp))
                If IsNumeric(i.Value) Then
                    If i.Value > 0 Then
                        i.EntireRow.Copy
                        Sheets("Data").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
                    End If
                End If
            Next i
        Else
            Worksheets("Data").Activate
            MsgBox "String not found"
        End If
    Next StringToFind

End With

End Sub

在第二个 for 循环中可能还有一些其他的调整，所以当你迭代时它是有意义的，但这会让你在球场上。

Answer 2

类似的解决方案，专为灵活性和速度而设计：

Sub tgr()

    Dim wb As Workbook
    Dim wsSearch As Worksheet
    Dim wsData As Worksheet
    Dim rFound As Range
    Dim rCopy As Range
    Dim rTemp As Range
    Dim aFindStrings() As String
    Dim vFindString As Variant
    Dim sTemp As String
    Dim sFirst As String
    Dim i As Long, j As Long
    Dim bExists As Boolean

    Set wb = ActiveWorkbook
    Set wsSearch = wb.Sheets("Skills Matrix")
    Set wsData = wb.Sheets("Data")
    ReDim aFindStrings(1 To 65000)
    i = 0

    Do
        sTemp = vbNullString
        sTemp = InputBox("Enter string to find", "Find string")
        If Len(sTemp) > 0 Then
            bExists = False
            For j = 1 To i
                If aFindStrings(j) = sTemp Then
                    bExists = True
                    Exit For
                End If
            Next j
            If Not bExists Then
                i = i + 1
                aFindStrings(i) = sTemp
            End If
        Else
            'User pressed cancel or left entry blank
            Exit Do
        End If
    Loop

    If i = 0 Then Exit Sub  'User pressed cancel or left entry blank on the first prompt

    ReDim Preserve aFindStrings(1 To i)
    For Each vFindString In aFindStrings
        Set rFound = Nothing
        Set rFound = wsSearch.Rows(1).Find(vFindString, wsSearch.Cells(1, wsSearch.Columns.Count), xlValues, xlWhole)
        If Not rFound Is Nothing Then
            sFirst = rFound.Address
            Do
                For Each rTemp In wsSearch.Range(rFound.Offset(1), wsSearch.Cells(wsSearch.Rows.Count, rFound.Column).End(xlUp)).Cells
                    If IsNumeric(rTemp) And rTemp.Value > 0 Then
                        If rCopy Is Nothing Then
                            Set rCopy = rTemp.EntireRow
                        Else
                            Set rCopy = Union(rCopy, rTemp.EntireRow)
                        End If
                    End If
                Next rTemp
                Set rFound = wsSearch.Rows(1).FindNext(rFound)
            Loop While rFound.Address <> sFirst
        Else
            MsgBox "[" & vFindString & "] not found."
        End If
    Next vFindString

    If Not rCopy Is Nothing Then rCopy.Copy wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Offset(1)

End Sub