View Full Version : Macro to find numbers in a single column
frogman
04-24-2016, 01:00 PM
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
04-25-2016, 06:28 AM
do you want to copy from area 1 to area 2?
do you also want to highlight number so found?
frogman
04-25-2016, 08:44 AM
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
04-26-2016, 11:32 AM
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
04-27-2016, 07:47 AM
Did you happen to test this code?
excelliot
04-27-2016, 07:56 AM
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
04-30-2016, 03:13 PM
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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.