Question

我有这个代码，但是我希望它能找到两个相邻的单元格，其中A列中的值为7和2（每对中有7个），偏移量（从7开始）到下一列并插入值到特定行范围。

Sub mark()
    Dim FirstAddress As String
    Dim MyArr As Variant
    Dim Rng As Range
    Dim I As Long

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    MyArr = Array("X")

    With Sheets("Sheet1").Range("A:A")

        .Offset(0, 1).ClearContents

        For I = LBound(MyArr) To UBound(MyArr)


            Set Rng = .Find(What:=MyArr(I), _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlFormulas, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)

            If Not Rng Is Nothing Then
                FirstAddress = Rng.Address
                Do

                    Rng.Offset(0, 1).Value = "X"
                    Set Rng = .FindNext(Rng)
                Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
            End If
        Next I
    End With

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

任何建议表示赞赏。

Answer 1

请尝试此代码。我已经扩展它以指定在指定位置插入不同的结果。

Sub Mark2()
    ' 14 Feb 2018

    Dim Ws As Worksheet
    Dim Crits() As Variant
    Dim Fun() As Variant
    Dim MarkRng As Range
    Dim R As Long
    Dim i As Long
    Dim Count As Integer

    Set Ws = Worksheets("FindPair")                 ' replace with actual name
    Crits = Array(7, 2, 13, 3, 17, 4)               ' 1st, 2nd, 1st, 2nd, 1st, 2nd criterium
    ' Match the ranges in Fun() to the targets in Crits()
        ' 2 ranges for each Crit, each range 1 or more cells
        ' Omitted ranges must be represented by a comma
        ' Fun ranges specified in excess of available space will be ignored
        ' (for example, A32 + B28:B32 = 6 cells but MarkRng has only 5 cells)
    Fun = Array("A32", "B28:B32", "A33:A35", "B33:B34", , "B100:B104")

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    For i = LBound(Crits) To UBound(Crits) Step 2
        Count = 0
        Do
            R = MatchRow(Crits(i), Ws, (R = 0))
            If R Then
                With Ws
                    If .Cells(R + 1, 1).Value = Crits(i + 1) Then
                        ' column 2 = column B
                        Set MarkRng = Range(.Cells(R, 2), .Cells(R + 5, 2))
                        WriteResult i, Fun, MarkRng
                        Count = Count + 1
                    End If
                End With
            Else
                If Count = 0 Then
                    MsgBox "No match was found for " & Crits(i), _
                           vbInformation, "Failure advice"
                    End If
                Exit Do
            End If
        Loop
    Next i

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Private Function MatchRow(ByVal Crit As Variant, _
                          Ws As Worksheet, _
                          ByVal NewSearch As Boolean) As Long
    ' 13 Feb 2018

    Static Rng As Range
    Static Rstart As Long
    Static Rend As Long
    Dim Fnd As Range

    With Ws
        If NewSearch Then
            Rstart = 2                          ' start search in row 2
            ' find last used row
            Rend = .Cells(.Rows.Count, 1).End(xlUp).Row
        End If

        Set Rng = Range(.Cells(Rstart, 1), .Cells(Rend, 1))
    End With

    With Rng
        Set Fnd = .Find(What:=Crit, _
                        After:=.Cells(.Cells.Count), _
                        LookIn:=xlFormulas, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
    End With

    If Not Fnd Is Nothing Then
        MatchRow = Fnd.Row
        Rstart = Fnd.Row + 1
    End If
End Function

Private Sub WriteResult(ByVal Ix As Long, _
                        Fun() As Variant, _
                        Target As Range)
    ' 14 Feb 2018

    Dim Ws As Worksheet
    Dim Rng As Range, R As Long                 ' source
    Dim Rt As Long
    Dim i As Long

    With Target
        Set Ws = .Worksheet
        For i = 0 To 1
            If Not IsError(Fun(Ix + i)) Then
                Set Rng = Ws.Range(Fun(Ix + i))
                For R = 1 To Rng.Cells.Count
                    If Rt < .Cells.Count Then
                        Rt = Rt + 1
                        .Cells(Rt).Value = Rng.Cells(R).Value
                    End If
                Next R
            End If
        Next i
    End With
End Sub

找到两个连续的数字

1 个答案: