Macro to find numbers in a single column

[frogman]

Is there a way to search for a single column or any two columns of numbers and place them on a new sheet for review. I would like to be able to look for any-wheres from 2 to 20 of liked numbers. In this example am looking for four 3s so I place four 3s in AN5:AN8 and press the search button. I would also like to catch 15 rows above and below the numbers I am looking for. An example of what it finds is below

Here is a snip of what I am asking for.



16004

[excelliot]

do you want to copy from area 1 to area 2?

do you also want to highlight number so found?

[frogman]

do you want to copy from area 1 to area 2? yes, prefer answers to go on another sheet "if possible" and catch 15 rows above and below the numbers I am searching for

do you also want to highlight number so found? I would prefer a thick black border

Here is a file

[excelliot]

Try below macro:



Sub ExcelRangePattern()
Dim sRng As Range
Dim mRng As Range
Dim found As Range
Dim fAdd As String
Dim tRng As Range
Dim aw As WorksheetFunction
Dim cpyRange As Range
Dim fRow As Integer, lRow As Integer
Dim fCol As Integer, lCol As Integer
Dim tmpWS As Worksheet
Dim pasteCell As Range


Set aw = Application.WorksheetFunction
Set mRng = Range("W1:Z56") 'Change range as per your choice
Set sRng = Range("AB5").CurrentRegion


Set found = mRng.Find(What:=sRng.Item(1, 1).Value)
'Debug.Print sRng.Item(1, 1).Value
'Debug.Print found.Address
If Not Evaluate("ISREF('ExcelVbaLab.Com'!A1)") Then
Set tmpWS = Sheets.Add(After:=Worksheets(Worksheets.Count))
tmpWS.Name = "ExcelVbaLab.Com"
tmpWS.[a1] = " "
Sheets("ExcelVbaLab.Com").Columns.ColumnWidth = 5
Else
Set tmpWS = Sheets("ExcelVbaLab.Com")
tmpWS.Cells.Clear
tmpWS.[a1] = " "
Sheets("ExcelVbaLab.Com").Columns.ColumnWidth = 5
End If

If Not found Is Nothing Then
fAdd = found.Address
Do
Set tRng = Nothing
Set tRng = Range(found, Cells(found.Row - 1 + sRng.Rows.Count, found.Column - 1 + sRng.Columns.Count))
'Debug.Print tRng.Address

If aw.Var(sRng, tRng) = 0 Then
Call BBold(tRng)

fRow = aw.Max(1, found.Row - 15)
lRow = found.Row + 15
fCol = mRng.Column
lCol = Range(Split(mRng.Address, ":")(1) & "1").Column
'tmpWS.Select

Set pasteCell = Cells(1, tmpWS.Cells.Find(What:="*", After:=[a1], SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Column)

Debug.Print pasteCell.Address

Set pasteCell = pasteCell.Offset(0, 2)

Range(Cells(fRow, fCol), Cells(lRow, lCol)).Copy Destination:=tmpWS.Range(pasteCell.Address)
'tmpWS.Range("ZZ1").Paste
Call BReg(tRng)
Application.CutCopyMode = False
End If
Set found = mRng.FindNext(found)
If found Is Nothing Then Exit Do
Loop While found.Address <> fAdd
End If


End Sub
Function BBold(rng As Range)
With rng.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With rng.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With rng.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With rng.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
rng.Borders(xlInsideVertical).LineStyle = xlNone
With rng.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With


End Function
Function BReg(rng As Range)
rng.Borders(xlDiagonalDown).LineStyle = xlNone
rng.Borders(xlDiagonalUp).LineStyle = xlNone
With rng.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End Function





Do let me know if you need any help..

Cheers!!

[excelliot]

Did you happen to test this code?

[excelliot]

you can try this one since this one ignores current range which is already considered:



Sub ExcelRangePattern()
Dim sRng As Range
Dim mRng As Range
Dim found As Range
Dim fAdd As String
Dim tRng As Range
Dim aw As WorksheetFunction
Dim cpyRange As Range
Dim fRow As Integer, lRow As Integer
Dim fCol As Integer, lCol As Integer
Dim tmpWS As Worksheet
Dim pasteCell As Range


Set aw = Application.WorksheetFunction
Set mRng = Range("W1:Z56") 'Change range as per your choice
Set sRng = Range("AB5").CurrentRegion


Set found = mRng.Find(What:=sRng.Item(1, 1).Value)
'Debug.Print sRng.Item(1, 1).Value
'Debug.Print found.Address
If Not Evaluate("ISREF('ExcelVbaLab.Com'!A1)") Then
Set tmpWS = Sheets.Add(After:=Worksheets(Worksheets.Count))
tmpWS.Name = "ExcelVbaLab.Com"
tmpWS.[a1] = " "
Sheets("ExcelVbaLab.Com").Columns.ColumnWidth = 5
Else
Set tmpWS = Sheets("ExcelVbaLab.Com")
tmpWS.Cells.Clear
tmpWS.[a1] = " "
Sheets("ExcelVbaLab.Com").Columns.ColumnWidth = 5
End If

If Not found Is Nothing Then
fAdd = found.Address
Do
Set tRng = Nothing
Set tRng = Range(found, Cells(found.Row - 1 + sRng.Rows.Count, found.Column - 1 + sRng.Columns.Count))
'Debug.Print tRng.Address

If aw.Var(sRng, tRng) = 0 Then
Call BBold(tRng)

fRow = aw.Max(1, found.Row - 15)
lRow = found.Row + 15
fCol = mRng.Column
lCol = Range(Split(mRng.Address, ":")(1) & "1").Column
'tmpWS.Select

Set pasteCell = Cells(1, tmpWS.Cells.Find(What:="*", After:=[a1], SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Column)

Debug.Print pasteCell.Address

Set pasteCell = pasteCell.Offset(0, 2)

Range(Cells(fRow, fCol), Cells(lRow, lCol)).Copy Destination:=tmpWS.Range(pasteCell.Address)
'tmpWS.Range("ZZ1").Paste
Call BReg(tRng)
Application.CutCopyMode = False
End If
Set found = mRng.FindNext(tRng.Item(tRng.Rows.Count).Offset(1, 0)) 'found
If found Is Nothing Then Exit Do
Loop While found.Address <> fAdd
End If


End Sub
Function BBold(rng As Range)
With rng.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With rng.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With rng.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With rng.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
rng.Borders(xlInsideVertical).LineStyle = xlNone
With rng.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With


End Function
Function BReg(rng As Range)
rng.Borders(xlDiagonalDown).LineStyle = xlNone
rng.Borders(xlDiagonalUp).LineStyle = xlNone
With rng.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With rng.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End Function





Cheers!!

[frogman]

so sorry, I will check this out tonight. When they own you as a frogman you go when they say go. I will report back