Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Need help speeding this up
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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Speeding up calculations | Excel Discussion (Misc queries) | |||
Speeding Up A Spreadsheet | Excel Discussion (Misc queries) | |||
Speeding Up Code | Excel Programming | |||
help with speeding this up... | Excel Programming | |||
speeding up vlookup | Excel Programming |