Search Multiple different string in excel VBA

Question

i am trying to allow the user to search up to 6 different types of strings( text). However i have tried it for up to 2 ,

Problem

but my code only performs the search correctly for the first one. However any of the searches after fisrt string are not achieving the objective.

Objective

The objective of the code is for it to find the string in the speficied row, then search that coloumn for values greater than zero, if so copy the whole row.

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

Thank you

Answer 1

Instead of storing your string's to search in seperate variables, put them into an array. You can iterate through arrays using a For Each loop so it's a perfect fit:

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

There's probably some other tweaks inside that second for loop to make so it makes sense when you iterate, but this will get you in the ballpark.

Answer 2

Similar solution, designed for flexibility and speed:

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