Return smallest values

This is pretty specific to what you wanted, if you need it altered, let me know.

' (Declarations)
Type RangeCellInfo ' stores all changes made by the macro
CellContent As Variant
CellAddress As String
End Type

Public OrgWB As Workbook
Public OrgWS As Worksheet
Public OrgCells() As RangeCellInfo

' (End Declarations)
Sub SmallestValues
Application.ScreenUpdating = False
Dim CurrentRow As Integer
Dim NumofEntries As Integer
Dim Max As Boolean
Dim NumberEntered As Integer
Dim FillRow As Integer
Dim i As Integer, cl As Range
If TypeName(Selection) <> "Range" Then Exit Sub

Range("A1:B6").Select
ReDim OrgCells(Selection.Count)
Set OrgWB = ActiveWorkbook
Set OrgWS = ActiveSheet
i = 1
For Each cl In Selection
OrgCells(i).CellContent = cl.Formula
OrgCells(i).CellAddress = cl.Address
i = i + 1
Next cl

Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom


NumofEntries = Application.WorksheetFunction.CountA(Range("A:A"))
CurrentRow = 0
Max = False
NumberEntered = 0

Do While Max = False
CurrentRow = CurrentRow + 1
If Cells(CurrentRow, 2) <> 0 Then
FillRow = FillRow + 1
Cells(FillRow, 3).Value = Cells(CurrentRow, 1).Value
NumberEntered = NumberEntered + 1
End If
If NumberEntered = 3 Then Max = True
Loop
Call UndoEditRange
Application.ScreenUpdating = True
End Sub

Sub UndoEditRange()
Dim i As Integer
On Error GoTo NoWBorWS
OrgWB.Activat