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

搜索多个字符串并在Excel VBA宏中的上一个单元格中分配字符串

2 个答案: