Wow. This is interesting and slow. Any ideas?
 

I had some fun with this one.

I didn't know how to do the selector using an algorithm, so I used a
geometric solution (Selector and DelBlanks.) Any ideas on how to speed
this up?

Sub GetUniques()

Worksheets("Selection").Columns("A").Parse _
parseLine:="[xxxxx] [.xx]", _
Destination:=Worksheets("Selection").Range("D1")
Range("D1", Range("D1").End(xlDown)).NumberFormat = "@"

Worksheets("Selection").Range("D1").Value = "Portfolio"
Worksheets("Selection").Range("E:E").Clear

Range("D1", Range("D1").End(xlDown)).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=Range("F2").End(xlUp)(2),
Unique:=True

End Sub

Public Sub Selector()

Dim SelectorColumn As Range
Dim nbCells As Integer
Dim Master As Range
Dim i As Integer
Dim Minimum As Double
Dim pstRange As Range

Set Master = Range("G3", Range("N3").End(xlDown))

nbCells = Application.WorksheetFunction.Count(Master)

Master.Copy
Range("AK4").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False

For i = 1 To nbCells
Set SelectorColumn = Range("AK4:AK38")
Set pstRange = Range("AG2").Offset(i, 0)

SelectorColumn.Select
Call DelBlanks
Set SelectorColumn = Range("AK4:AK38")
SelectorColumn.NumberFormat = "0.00000"

Minimum = Application.WorksheetFunction.Min(SelectorColumn)

pstRange = Minimum

SelectorColumn.Find(Minimum).Clear

Next i

End Sub



Sub DelBlanks()

Dim rng As Range
Dim Cel As Range
Dim DelRng As Range

Set DelRng = Nothing
Set rng = ActiveSheet.Range("AK4", Range("AR4").End(xlDown))

For Each Cel In rng
If Len(Trim(Cel.Value)) = 0 Then
If DelRng Is Nothing Then
Set DelRng = Cel
Else
Set DelRng = Union(DelRng, Cel)
End If
End If
Next

If Not DelRng Is Nothing Then
DelRng.Delete Shift:=xlToLeft
End If

End Sub


James