Jack-P-Winner
Member
I do not want to double post but I accidently posted this on the excel forum and afterwards realized it belongs here so my apologies
I have this Macro that searches for specific groups of numbers. I added another 300,000 rows and when I search for say a group that is all the way almost on the bottom of my spreadsheet it does not find it as if it is limited to only go to a certain row. Can anyone tell me what may be wrong with my MACRO? I have 750,000 rows presently and will be adding more
https://app.box.com/s/ci5xymcdj3fe5c2wjjqf
Thanks
Here is the MACRO
I have this Macro that searches for specific groups of numbers. I added another 300,000 rows and when I search for say a group that is all the way almost on the bottom of my spreadsheet it does not find it as if it is limited to only go to a certain row. Can anyone tell me what may be wrong with my MACRO? I have 750,000 rows presently and will be adding more
https://app.box.com/s/ci5xymcdj3fe5c2wjjqf
Thanks
Here is the MACRO
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