Jack-P-Winner
Member
I would like to add an option to select less rows for a search. Presently I enter data in rows 3 through 11 and it finds up to as many ahead and behind 9 rows of data. I would like to add an option to search for say 6 rows of data instead and place 4 counter numbers in rows 3 though 8. How can I change my code to do this?
Thanks Gurus
https://www.dropbox.com/s/r5wfwh6iulyjbzk/Pattern_Search_forum.xlsm
Thanks Gurus
https://www.dropbox.com/s/r5wfwh6iulyjbzk/Pattern_Search_forum.xlsm
Code:
Option Explicit
Sub PatternSearch()
Dim c00, sn, st
Dim j, jj As Long, dPRw As Double, sPat As String
Dim iAbv, iBlw As Integer, rCel, rPtn As Range
iAbv = [N3]
iBlw = [N4]
dPRw = Range("H3:H" & Range("H" & Rows.Count).End(xlUp).Row).Cells.Count
Set rPtn = Range("H3:K" & Range("K" & Rows.Count).End(xlUp).Row)
If [N3] = vbNullString Or [N4] = vbNullString Then
MsgBox "You must enter a value (even if it is 0) for Above and Below", , "Missing Value"
Exit Sub
End If
For Each rCel In rPtn
sPat = sPat & rCel
Next
c00 = [sPat]
If Len(c00) <> dPRw * 4 Then
MsgBox "Search criterion not complete. Enter 4 numbers for each row.", , "Criteria missing"
Exit Sub
End If
Sheet2.Columns("L:Q").ClearContents
sn = Sheet1.Cells(12, 1).CurrentRegion
For j = 1 To UBound(sn) - dPRw
If sn(j, 2) = Val(Left(c00, 1)) Then
For jj = 0 To (dPRw * 4) - 1
If sn(j + jj \ 4, jj Mod 4 + 2) <> Val(Mid(c00, jj + 1, 1)) Then Exit For
Next
If jj = dPRw * 4 Then
ReDim st(1 To (dPRw + iAbv + iBlw), 1 To 6)
For jj = 1 To (dPRw + iAbv + iBlw) * 6
If j - iAbv + (jj - 1) \ UBound(st, 2) > UBound(sn) Then Exit For
If j < iAbv And jj > UBound(sn, 2) * (dPRw + iBlw - 1 + j) Then Exit For
st((jj - 1) \ UBound(st, 2) + 1, (jj - 1) Mod UBound(st, 2) + 1) = sn(Application.Max(j - (iAbv + 1), 0) + (jj - 1) \ UBound(st, 2) + 1, (jj - 1) Mod UBound(st, 2) + 1)
Next
Sheet2.Cells(Rows.Count, 12).End(xlUp).Offset(2).Resize(UBound(st), UBound(st, 2)) = st
End If
End If
Next
With Sheet2
.Columns("Q").AutoFit
.[L1] = "Search Results"
End With
If Sheet2.[L3] = vbNullString Then
MsgBox "No matching pattern found", , "No Match"
Application.Goto ([L2])
Else
Application.Goto (Sheet2.[L1])
End If
End Sub
Last edited by a moderator: