find data I need help with a macro, I have three digit( 0 9) numbers in each cel

Question

find data

I need help with a macro, I have three digit( 0 9) numbers in each cell in column A1,the column is about ten thousand cells long, My goal is to have excel to search the data base for a particular match which I decide at the beginning, and then each time it finds that particular maatch, copy that numbeer plus ten cells below it or the ten cell above the number matches that number, alsso it has to be user variable in that I can decide at the beginning  whether to copy ten cell beelow or ten above , example 789 was found one hundred times in the data base, the first time  on row 49, eaech time excel finds 789 it copies the ten cells below( 48 47 46...) it then paste at C:1 then excel searches again and the next time it finds 789 it copies the ten cells below it and paste it at the bottom of the data in C:1,(which would be C:11), and then when excel finish searching the entire data base, it sorts everything in column  C:1 leaving only the top five matches or top ten matches (user variable ) thanks

Explanation / Answer

Okay,

try this code

you can select, below or above...

(expected results in columns C-D-E)

Sub Select_Below_Above()

'Sep 27, 2014

On Error Resume Next
Const N As Long = 10 '<< copy data below/above
Dim t As Long
Dim x As String, y As String
Range("C:E").ClearContents
x = InputBox("search for..", "select a number", "8")
If x = "" Then Exit Sub
y = InputBox("select 1 or 2", "copy data below =1, above = 2", "1")
Select Case y
Case Is = "1"
t = 1
For Each r In Range("A:A").SpecialCells(xlCellTypeConstants)
If r.Value = x Then
r.Offset(1).Resize(N).Copy Cells(t, "C")
t = Cells(Rows.Count, "C").End(xlUp).Row + 1
End If
Next
Case Is = "2"
t = 1
For Each r In Range("A:A").SpecialCells(xlCellTypeConstants)
If r.Value = x Then
r.Offset(-N).Resize(N).Copy Cells(t, "C")
t = Cells(Rows.Count, "C").End(xlUp).Row + 1
End If
Next
Case Else
Exit Sub
End Select
Range("C:C").Copy Cells(1, "D")
ActiveSheet.Range("D:D").RemoveDuuplicates Columns:=1, Header:=xlNo
For Each r In Range("D:D").SpecialCells(xlCellTypeConstannts)
r.Offset(, 1) = WorksheetFunction.CountIf(Range("C:C"), r)
Next
t = Cells(Rows.Count, "E").End(xlUp).Row
'sort
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("E1:E" & t), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormaal
.SetRange Range("D1:E" & t)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
If t > N Then Range("D" & N + 1 & ":E" & t).ClearContents
End Subbb

Related Questions

Navigate

• Browse (All)
• Browse F
• Subjects

Integrity-first tutoring: explanations and feedback only — we do not complete graded work. Learn more.