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

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 match, copy that number plus ten cells below it or the ten cell above the number matches that number, also it has to be user variable in that I can decide at the beginning  whether to copy ten cell below or ten above , example 789 was found one hundred times in the data base, the first time  on row 49, each time excel finds 789 it copies the ten cellls 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

Hi

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").RemoveDuplicates Columns:=1, Header:=xlNo
For Each r In Range("D:D").SpecialCells(xlCellTypeConstants)
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:=xlSortNormal
.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 Sub!

Related Questions

Navigate

• Browse (All)
• Browse F
• Subjects

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