Limiting vba returned value to the first 10 results

[bloodmilksky]

Hi Guys,

I am currently running the below code on my spreadsheet. which is working perfectly other than its returning too many values on some searches and was wondering if anyone knew how to reduce the results to the first 10 answers?

Many thanks

Jamie





Private Sub Worksheet_Change(ByVal Target As Range)
' Defines variables
Dim FindString As String, Rng As Range, sRange As Range, RowNo As Integer
' Defines LastRow as last row of column C of the Sales Rep sheet containing data
LastRow = Sheets("Sales Reps").Cells(Rows.Count, "C").End(xlUp).Row
' If target cell is A1 then...
If Not Intersect(Target, Range("A2")) Is Nothing Then
' If target value is not blank then...
If Target.Value <> "" Then
' Sets FindString as the value of A1 (case insensitive)
FindString = UCase(Target.Value)
' Sets search range as Sales Rep sheet C1 to last row
Set sRange = Sheets("Sales Reps").Range("C1:C" & LastRow)
' Set variable RowNo as 1
RowNo = 2
' For each cell in the search range
For Each Cell In sRange
' If the cell contains the FindString value (case insensitive) then...
If InStr(1, UCase(Cell.Value), FindString) Then
' Copy columns A:D of the cell row from Sales Rep and paste to the current RowNo of column B of Menu
Sheets("Sales Reps").Range("C" & Cell.Row, "G" & Cell.Row).Copy Range("B" & RowNo)
' Increase RowNo by 1 to account for the new data
RowNo = RowNo + 1
End If
' Check next cell in search range
Next Cell
' If the name was not found then...
If Range("B2") = "" Then
' Display an error stating the name is not in the list
MsgBox "Specified name does not exist", vbOKOnly, "Attention!"
' Clear the contents of A1
Target.ClearContents
' Reselect cell A1
Range("A2").Select
End If
' Else if A1 is empty...
Else
' Clear the contents of B:E on the Menu sheet
Range("B2:F11").ClearContents
End If
End If

 

[Alan_P]

Hi Jamie,

I've not been able to test this but it "should" work

Private Sub Worksheet_Change(ByVal Target As Range)

Dim FindString As String, Rng As Range, sRange As Range, RowNo As Integer[COLOR=#ff0000], Limit As Long[/COLOR]

LastRow = Sheets("Sales Reps").Cells(Rows.Count, "C").End(xlUp).Row

If Not Intersect(Target, Range("A2")) Is Nothing Then

    If Target.Value <> "" Then

        FindString = UCase(Target.Value)
        Set sRange = Sheets("Sales Reps").Range("C1:C" & LastRow)
        RowNo = 2
        [COLOR=#ff0000]Limit = 1
[/COLOR]
        For Each Cell In sRange
            If InStr(1, UCase(Cell.Value), FindString) Then
                Sheets("Sales Reps").Range("C" & Cell.Row, "G" & Cell.Row).Copy Range("B" & RowNo)
                RowNo = RowNo + 1
                [COLOR=#ff0000]Limit = Limit + 1
                If Limit = 11 Then GoTo LimitReached[/COLOR]
            End If
        Next Cell
        
[COLOR=#ff0000]LimitReached:[/COLOR]

        If Range("B2") = "" Then
            MsgBox "Specified name does not exist", vbOKOnly, "Attention!"
            Target.ClearContents
            Range("A2").Select
        End If

    Else
        Range("B2:F11").ClearContents
    End If
End If

End Sub

Additions in red...

Hope this helps,
Cheers,
Alan.

 

[bloodmilksky]

Thats Great thank you Alan ^_^

 

[bloodmilksky]

Hi alan,

I have entered the suggested amendment in the 2nd paragraph of code and its coming up with an error "Duplicate Declaration In Current Scope"


Private Sub Worksheet_Change(ByVal Target As Range)
' Defines variables
Dim FindString As String, Rng As Range, sRange As Range, RowNo As Integer, Limit As Long
' Defines LastRow as last row of column C of the Sales Rep sheet containing data
LastRow = Sheets("Sales Reps").Cells(Rows.Count, "C").End(xlUp).Row
' If target cell is A1 then...
If Not Intersect(Target, Range("A2")) Is Nothing Then
' If target value is not blank then...
If Target.Value <> "" Then
' Sets FindString as the value of A1 (case insensitive)
FindString = UCase(Target.Value)
' Sets search range as Sales Rep sheet C1 to last row
Set sRange = Sheets("Sales Reps").Range("C1:C" & LastRow)
' Set variable RowNo as 1
RowNo = 2
Limit = 1
' For each cell in the search range
For Each Cell In sRange
' If the cell contains the FindString value (case insensitive) then...
If InStr(1, UCase(Cell.Value), FindString) Then
' Copy columns A:D of the cell row from Sales Rep and paste to the current RowNo of column B of Menu
Sheets("Sales Reps").Range("C" & Cell.Row, "G" & Cell.Row).Copy Range("B" & RowNo)
' Increase RowNo by 1 to account for the new data
RowNo = RowNo + 1
Limit = Limit + 1
If Limit = 11 Then GoTo LimitReached
End If
' Check next cell in search range
Next Cell
LimitReached:
' If the name was not found then...
If Range("B2") = "" Then
' Display an error stating the name is not in the list
MsgBox "Specified name does not exist", vbOKOnly, "Attention!"
' Clear the contents of A1
Target.ClearContents
' Reselect cell A1
Range("A2").Select
End If
' Else if A1 is empty...
Else
' Clear the contents of B:E on the Menu sheet
Range("B2:F11").ClearContents
End If
End If

' Defines LastRow as last row of column C of the Solutions sheet containing data
LastRow = Sheets("Solutions").Cells(Rows.Count, "C").End(xlUp).Row
' If target cell is A1 then...
If Not Intersect(Target, Range("A13")) Is Nothing Then
' If target value is not blank then...
If Target.Value <> "" Then
' Sets FindString as the value of A1 (case insensitive)
FindString = UCase(Target.Value)
' Sets search range as Solutions sheet C1 to last row
Set sRange = Sheets("Solutions").Range("C1:C" & LastRow)
' Set variable RowNo as 1
RowNo = 13
Limit = 1
' For each cell in the search range
For Each Cell In sRange
' If the cell contains the FindString value (case insensitive) then...
If InStr(1, UCase(Cell.Value), FindString) Then
' Copy columns A:D of the cell row from Solutions and paste to the current RowNo of column B of Menu
Sheets("Solutions").Range("C" & Cell.Row, "F" & Cell.Row).Copy Range("B" & RowNo)
' Increase RowNo by 1 to account for the new data
RowNo = RowNo + 1
Limit = Limit + 1
If Limit = 27 Then GoTo LimitReached
End If
' Check next cell in search range
Next Cell
LimitReached:
' If the name was not found then...
If Range("B13") = "" Then
' Display an error stating the name is not in the list
MsgBox "Specified name does not exist", vbOKOnly, "Attention!"
' Clear the contents of A1
Target.ClearContents
' Reselect cell A1
Range("A10").Select
End If
' Else if A1 is empty...
Else
' Clear the contents of B:E on the Menu sheet
Range("B13:F27").ClearContents
End If
End If

 

[Alan_P]

Hi Jamie,

The piece of code "LimitReached:" defines a place in the code, so when "Limit" = 27 it jumps to this place with the "GoTo" command...

As you have added the "LimitReached:" in twice the GoTo command does not know which one to go to and thus produces an error.

Luckily a simple fix just need to change the name

Private Sub Worksheet_Change(ByVal Target As Range)
 ' Defines variables
 Dim FindString As String, Rng As Range, sRange As Range, RowNo As Integer, Limit As Long
 ' Defines LastRow as last row of column C of the Sales Rep sheet containing data
 LastRow = Sheets("Sales Reps").Cells(Rows.Count, "C").End(xlUp).Row
 ' If target cell is A1 then...
 If Not Intersect(Target, Range("A2")) Is Nothing Then
 ' If target value is not blank then...
 If Target.Value <> "" Then
 ' Sets FindString as the value of A1 (case insensitive)
 FindString = UCase(Target.Value)
 ' Sets search range as Sales Rep sheet C1 to last row
 Set sRange = Sheets("Sales Reps").Range("C1:C" & LastRow)
 ' Set variable RowNo as 1
 RowNo = 2
 Limit = 1
 ' For each cell in the search range
 For Each Cell In sRange
 ' If the cell contains the FindString value (case insensitive) then...
 If InStr(1, UCase(Cell.Value), FindString) Then
 ' Copy columns A:D of the cell row from Sales Rep and paste to the current RowNo of column B of Menu
 Sheets("Sales Reps").Range("C" & Cell.Row, "G" & Cell.Row).Copy Range("B" & RowNo)
 ' Increase RowNo by 1 to account for the new data
 RowNo = RowNo + 1
 Limit = Limit + 1
 If Limit = 11 Then GoTo[COLOR=#ff0000] LimitReached1[/COLOR]
 End If
 ' Check next cell in search range
 Next Cell
[COLOR=#ff0000]LimitReached1:[/COLOR]
 ' If the name was not found then...
 If Range("B2") = "" Then
 ' Display an error stating the name is not in the list
 MsgBox "Specified name does not exist", vbOKOnly, "Attention!"
 ' Clear the contents of A1
 Target.ClearContents
 ' Reselect cell A1
 Range("A2").Select
 End If
 ' Else if A1 is empty...
 Else
 ' Clear the contents of B:E on the Menu sheet
 Range("B2:F11").ClearContents
 End If
 End If

 ' Defines LastRow as last row of column C of the Solutions sheet containing data
 LastRow = Sheets("Solutions").Cells(Rows.Count, "C").End(xlUp).Row
 ' If target cell is A1 then...
 If Not Intersect(Target, Range("A13")) Is Nothing Then
 ' If target value is not blank then...
 If Target.Value <> "" Then
 ' Sets FindString as the value of A1 (case insensitive)
 FindString = UCase(Target.Value)
 ' Sets search range as Solutions sheet C1 to last row
 Set sRange = Sheets("Solutions").Range("C1:C" & LastRow)
 ' Set variable RowNo as 1
 RowNo = 13
 Limit = 1
 ' For each cell in the search range
 For Each Cell In sRange
 ' If the cell contains the FindString value (case insensitive) then...
 If InStr(1, UCase(Cell.Value), FindString) Then
 ' Copy columns A:D of the cell row from Solutions and paste to the current RowNo of column B of Menu
 Sheets("Solutions").Range("C" & Cell.Row, "F" & Cell.Row).Copy Range("B" & RowNo)
 ' Increase RowNo by 1 to account for the new data
 RowNo = RowNo + 1
 Limit = Limit + 1
 If Limit = 27 Then GoTo [COLOR=#ff0000]LimitReached2[/COLOR]
 End If
 ' Check next cell in search range
 Next Cell
[COLOR=#ff0000]LimitReached2:[/COLOR]
 ' If the name was not found then...
 If Range("B13") = "" Then
 ' Display an error stating the name is not in the list
 MsgBox "Specified name does not exist", vbOKOnly, "Attention!"
 ' Clear the contents of A1
 Target.ClearContents
 ' Reselect cell A1
 Range("A10").Select
 End If
 ' Else if A1 is empty...
 Else
 ' Clear the contents of B:E on the Menu sheet
 Range("B13:F27").ClearContents
 End If
 End If

if you need to add more you'll have to either change the name completely or increment the number each time...

Hopefully it will work properly now Feel free to come back if you need anything else

Cheers,
Alan.