搜索多個字符串並在Excel VBA宏中的前一個單元格中分配一個字符串

Question

我有每個需要在第2列進行搜索的字符串集合，如果它找到字符串Offset（0，-1）並將給定文本放在那裏，併爲每組字符串和每組文本重複該過程。我試着下面的查詢，但得到91錯誤。請有人幫助我。

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

這似乎是波紋管。

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

我不能得到正常，你想要什麼，但下面的代碼減少似乎工作....

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