Search Multiple strings and assign a string in previous cell in Excel VBA Macro

Question

I have each set of strings which required to search in column 2, if it finds the string, Offset(0, -1) and place given text there, and repeat the process for each set of strings and for each set of text. i tried below query but getting 91 error. please some one help me out.

Sub Sample()
    Dim MyAr(1 To 3) As String
    Dim MyAr1(1 To 3) As String
    Dim ws As Worksheet

    Dim aCell As Range, bCell As Range
    Dim cCell As Range, dCell As Range
    Dim i As Long
    Dim x As Long

    Set ws = ThisWorkbook.Sheets("Sheet1")

    MyAr(1) = "grant"
    MyAr(2) = "grant2"
    MyAr(3) = "grant3"

    MyAr1(1) = "cancel"
    MyAr1(2) = "expired"

    With ws
        '~~> Loop through the array
        For i = LBound(MyAr) To UBound(MyAr)
            Set aCell = .Columns(2).Find(What:=MyAr(i), LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)

            If Not aCell Is Nothing Then
                Set bCell = aCell
                'aCell.Interior.ColorIndex = 3
                aCell.Offset(0, -1).Value = "g\"

                Do
                    Set aCell = .Columns(2).FindNext(After:=aCell)

                    If Not aCell Is Nothing Then
                        If aCell.Address = bCell.Address Then Exit Do
                       'aCell.Interior.ColorIndex = 3
                    Else
                        Exit Do
                    End If
                Loop
            End If
        Next

            For x = LBound(MyAr1) To UBound(MyAr1)
            Set cCell = .Columns(2).Find(What:=MyAr1(x), LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)

            If Not aCell Is Nothing Then
                Set dCell = cCell
                cCell.Offset(0, -1).Value = "c\"

                Do
                    Set cCell = .Columns(2).FindNext(After:=cCell)

                    If Not cCell Is Nothing Then
                        If cCell.Address = dCell.Address Then Exit Do
                    Else
                        Exit Do
                    End If
                Loop
            End If
        Next
    End With
End Sub

Sample image

Answer 1

It seems to be bellow.

Sub test()
Dim aCell As Range, bCell As Range
Dim cCell As Range, dCell As Range
Dim i As Long
Dim x As Long

Set ws = ThisWorkbook.Sheets("Sheet1")

MyAr(1) = "grant"
MyAr(2) = "grant2"
MyAr(3) = "grant3"

MyAr1(1) = "cancel"
MyAr1(2) = "expired"

With ws
    '~~> Loop through the array
    For i = LBound(MyAr) To UBound(MyAr)
        Set aCell = .Columns(2).Find(What:=MyAr(i), LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)

        If Not aCell Is Nothing Then
            Set bCell = aCell
            'aCell.Interior.ColorIndex = 3
            Do
                aCell.Offset(0, -1).Value = "g\"

                Set aCell = .Columns(2).FindNext(After:=aCell)
            Loop Until aCell.Address = bCell.Address Or aCell Is Nothing
        End If
    Next

        For x = LBound(MyAr1) To UBound(MyAr1)
        Set cCell = .Columns(2).Find(What:=MyAr1(x), LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)

        If Not aCell Is Nothing Then
            Set dCell = cCell


            Do
                cCell.Offset(0, -1).Value = "c\"
                Set cCell = .Columns(2).FindNext(After:=cCell)

            Loop Until aCell.Address = bCell.Address Or aCell Is Nothing
        End If
    Next


End With
End Sub

Answer 2

I can't get properly what you want, but the following reduced code seems to work....

Sub Sample()
    Dim MyAr(1 To 3) As String
    Dim MyAr1(1 To 2) As String
    Dim ws As Worksheet
    Dim aCell As Range, bCell As Range
    Dim cCell As Range, dCell As Range
    Dim i As Long
    Dim x As Long

    Set ws = ThisWorkbook.Sheets("Sheet1")

    MyAr(1) = "grant"
    MyAr(2) = "grant2"
    MyAr(3) = "grant3"

    MyAr1(1) = "cancel"
    MyAr1(2) = "expired"

    With ws
        '~~> Loop through the array
        For i = LBound(MyAr) To UBound(MyAr)
            Set aCell = .Columns(2).Find(What:=MyAr(i), LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)

            If Not aCell Is Nothing Then
                aCell.Offset(0, -1).Value = "g\"
            End If
        Next

        For x = LBound(MyAr1) To UBound(MyAr1)
            Set cCell = .Columns(2).Find(What:=MyAr1(x), LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)

            If Not cCell Is Nothing Then
                cCell.Offset(0, -1).Value = "c\"
            End If
        Next

    End With

End Sub