Find two consecutive numbers - excel

Question

I have this code, but I'd like for it to find two adjacent cells with the values 7 and 2 (7 first in every pair) in column A and offset (from the 7) to the next column and insert a value to a specific row range.
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
Any suggestions appreciated.

Answer 1

Please try this code. I have expanded it to provide for specifying different results to be inserted at the found location.
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