Need help speeding this up

[KD]

Hi All:

Thanks for all your help on my previous posts. I am really struggling
with this, so I am greatful for any assistance.

This routine is used to select minimum values under constraints for an
operational/asset risk management portfolio. It works, but it is so
slow as to be almost be useless.

Get uniques populates a list with parsed unique portfolio names
[xxxxx]. The [.xx] is a percentage funding descriptor (can be thought
of a s portfolio weight.)

Selector takes a matrix ([xxxxx] rows, [.xx] columns) that is populated
with risk scores, copies it deletes all blanks and shifts left (sub
delblanks). Then the loop (this is what is so slow.) The lowest value
is then chosen and put in the choice list. The value is deleted from
the copied matrix, and then it loops.

The fundamental problem is that a 10% funding level for a particular
portfolio cannot be chosen before a 3% funding level. Our funding
choices have to be incremental, so higher funding cannot be chosen
before the lower level.

This whole thing is fairly easy to do manually. The criteria is not
that tough except that I don't have the CS background to translate it
into code, although I am learning quickly. Not to mention that there
are 6000 portfolios. How do I speed it up? What is the approach to
designing a routine for a problem of this type? I tried using a
constrained optimization (lagrangian) but couldn't translate it into
VBA. I tried using nested if-then statements, but I quickly lost my
way. This solution, the geometric one, is understandable and simple,
but so inefficient! Any ideas?

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


Thanks,

Knightdo