8
\$\begingroup\$

I am trying to optimize my code and make it as fast as it can be, I have researched as much as I can and am now asking the community for any tips because there are definitely people more experienced than me :).

As of now it is pretty slow for what I am trying to do. The innermost loop will basically loop choices^6 number of times. I will have anywhere from 5 choices up to ~32 choices.

In my main body of code I have three if statements setup that go from most likely to fail to least likely to fail the if condition ie. I am trying to optimize the logic so that I can go through all of the combinations as fast as possible.

Sub a_combinations()
    Dim pool As Worksheet
    Dim results As Worksheet
    Dim myBook As Workbook

    Dim j As Long, k As Long, l As Long, m As Long, n As Long, o As Long, p As Long
    Dim Gmax As Integer
    Dim counter As Long


    Dim maxsalary As Double
    Dim minsalary As Double
    Dim cursalary As Double

    Dim totalID As Double

    'speed up macro
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False


    Set myBook = Excel.ActiveWorkbook
    Set pool = myBook.Sheets("pool")
    Set results = myBook.Sheets("results")

    j = 1
    k = 2
    l = 3
    m = 4
    n = 5
    p = 6

    o = 1

    'maxsalary = 49400
    'minsalary = 45600
    maxsalary = 100000
    minsalary = 0
    cursalary = 0
    counter = 0
    totalID = 0

    Gmax = Worksheets("pool").Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
    Sheets("results").UsedRange.ClearContents

    Do While j <= Gmax - 5
        Do While k <= Gmax - 4
            Do While l <= Gmax - 3
                Do While m <= Gmax - 2
                    Do While n <= Gmax - 1
                        Do While p <= Gmax
                            'most likely to fail to least likely to fail
                            If j <> k And j <> l And j <> m And j <> n And j <> p And k <> l And k <> m And k <> n And k <> p And l <> m And l <> n And l <> p And m <> n And m <> p And n <> p Then 'takes care of doubles in lineup

                                cursalary = getSalary(pool.Cells(j, 1).Value) + getSalary(pool.Cells(k, 1).Value) + getSalary(pool.Cells(l, 1).Value) + getSalary(pool.Cells(m, 1).Value) + getSalary(pool.Cells(n, 1).Value) + getSalary(pool.Cells(p, 1))
                                If cursalary <= maxsalary And cursalary >= minsalary Then

                                    totalID = totalID + getID(pool.Cells(j, 1).Value) + getID(pool.Cells(k, 1).Value) + getID(pool.Cells(l, 1).Value) + getID(pool.Cells(m, 1).Value) + getID(pool.Cells(n, 1).Value) + getID(pool.Cells(p, 1).Value)
                                    If checkFlag(totalID) Then

                                        results.Cells(o, 1).Value = pool.Cells(j, 1).Value
                                        results.Cells(o, 2).Value = pool.Cells(k, 1).Value
                                        results.Cells(o, 3).Value = pool.Cells(l, 1).Value
                                        results.Cells(o, 4).Value = pool.Cells(m, 1).Value
                                        results.Cells(o, 5).Value = pool.Cells(n, 1).Value
                                        results.Cells(o, 6).Value = pool.Cells(p, 1).Value

                                        results.Cells(o, 7).Value = cursalary
                                        results.Cells(o, 8).Value = totalID

                                        o = o + 1
                                        counter = counter + 1
                                    End If
                                End If

                                cursalary = 0
                                totalID = 0
                            End If
                            p = p + 1
                        Loop
                        p = 6
                        n = n + 1
                    Loop
                    n = 5
                    m = m + 1
                Loop
                m = 4
                l = l + 1
            Loop
            l = 3
            k = k + 1
        Loop
        k = 2
        j = j + 1
    Loop

    results.Cells(1, 10).Value = counter
    counter = 0

    'return workbook to normal
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

Function getSalary(name As String) As Double
Dim salary As Double
Dim z As Integer
Dim Total As Integer
Dim pasted As Worksheet
Dim book As Workbook
Dim results As Worksheet

Set book = Excel.ActiveWorkbook
Set pasted = book.Sheets("pasted")
Set results = book.Sheets("results")

Total = Worksheets("pasted").Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count

For z = 1 To Total
    If pasted.Cells(z, 1).Value = name Then
        salary = pasted.Cells(z, 2).Value
        getSalary = salary
        Exit Function
    End If
Next z

End Function

Function getID(name As String) As Double
Dim eyeD As Double
Dim z As Integer
Dim Total As Integer
Dim pasted As Worksheet
Dim book As Workbook
Dim results As Worksheet

Set book = Excel.ActiveWorkbook
Set pasted = book.Sheets("pasted")
Set results = book.Sheets("results")

Total = Worksheets("pasted").Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count


For z = 1 To Total
    If pasted.Cells(z, 1).Value = name Then
        eyeD = pasted.Cells(z, 4).Value
        getID = eyeD
        Exit Function
    End If
Next z

End Function

Function checkFlag(idsum As Double) As Boolean
Dim z As Integer
Dim flag As Boolean
Dim Total As Integer
Dim pasted As Worksheet
Dim book As Workbook
Dim results As Worksheet
Dim test As Integer
Dim testrange As Range

Set book = Excel.ActiveWorkbook
Set pasted = book.Sheets("pasted")
Set results = book.Sheets("results")
Set testrange = book.Sheets("results").Range("H:H")

flag = False

test = Application.WorksheetFunction.countA(testrange)

If test = 0 Then
    flag = True
    checkFlag = flag
    Exit Function
Else
    Total = Worksheets("results").Range("H:H").Cells.SpecialCells(xlCellTypeConstants).Count
End If

flag = True

For z = 1 To Total
    If results.Cells(z, 8).Value = idsum Then
        flag = False
        checkFlag = flag
        Exit Function
    End If
Next z

checkFlag = flag
Exit Function

End Function

the getId function and if condition really just handles one thing, duplicated scenarios. I could avoid this if I knew how to properly setup an inner loop to do #choices choose 6 combinations. I am guessing that could probably save a ton of calculating time.

The getSalary and getId functions both work from a set choices by 1 array (column) while the checkFlag function works off of a dynamic array that will start at 1 x 1 (column) and grow to as large as ((choices choose 6) - 1) x 1.

Once again I am just looking for any advice on the above (working) code. It is as optimized as I could personally make it. Please let me know if I've done anything that isn't ideal I am more then happy to modify it per your suggestions.

\$\endgroup\$
11
\$\begingroup\$

1) The best performance gains often come from not hitting the sheet unless you really need to.

One way to do this is to read a whole range into an array, then access that instead of reading cell-by-cell.

For example:

Set pool = myBook.Sheets("pool")
'get all the values from ColA in an array
arrPool = pool.Range("A1", pool.Cells(Rows.Count, 1).End(xlUp)).Value

arrPool is now a 1-based 2-d array (n rows x 1 column). You can now replace all calls like this:

blah = pool.Cells(i,1)

with

blah = arrPool(i,1)

and your performance will be much better.

Note the reverse is also true: writing a 2-D array to a worksheet in one call is faster than writing cell-by-cell.

2) Your lookup functions are getting called with the same value over and over, so instead of repeating the work multiple times you can do something like this:

 Function getSalary(name As String) As Double

    Static dict As Object
    Dim f As Range

    If name = "reset" Then
        Set dict = Nothing 'reset store
        Exit Function
    End If 

    If dict Is Nothing Then Set dict = CreateObject("scripting.dictionary")

    If Not dict.exists(name) Then 'not already looked for this name

        Set f = ActiveWorkbook.Sheets("pasted").Range("A:A").Find(what:=name, _
                                      LookIn:=xlValues, lookat:=xlWhole)
        If Not f Is Nothing Then
            dict.Add name, f.Offset(0, 1).Value
        Else
            dict.Add name, -999 'not found
        End If
    End If
    getSalary = CDbl(dict(name)) 'return the stored value

 End Function

Once a name has been looked up, the result is stored in the dictionary, keyed on the name: retrieving that value is very fast compared to looking it up on the worksheet.

Use:

getSalary("reset")

to clear the stored values at the top of your code.

\$\endgroup\$
  • \$\begingroup\$ Thanks for the advice, I will modify the code per your suggestions and get back to you on how it performed. One quick question tho. When I try to call the function with "reset" as the name my text editor adds a space between getSalary and the first (. I got around it by setting the call to a random variable of the same type. Is this okay? \$\endgroup\$ – Ari F Jun 21 '16 at 15:31
  • \$\begingroup\$ Should be fine, yes. \$\endgroup\$ – Tim Williams Jun 21 '16 at 15:57
  • \$\begingroup\$ So i only had time today to update the three functions I call. I modified all of the code to use dicts only. With 12 choices the processing time went from ~54 seconds with my original "optimized heh" code to literally within 2 seconds. Note this doesn't include the multitude of Cell function calls in my main body which i will fix next. TYvm for the advice! \$\endgroup\$ – Ari F Jun 21 '16 at 19:29
  • \$\begingroup\$ shouldn't i write the arrays this way? Dim arrPool As Range Set arrPool = pool.Range("A1", pool.Cells(Rows.Count, 1).End(xlUp)) ? \$\endgroup\$ – Ari F Jun 23 '16 at 19:10
  • \$\begingroup\$ No you would Dim arrPool (not As Range) and you shouldn't use Set when assigning the value since arrPool is a Variant array, not an object. \$\endgroup\$ – Tim Williams Jun 23 '16 at 19:17
6
\$\begingroup\$

Okay, your code is incredibly difficult to understand. Even with your explanatory description, I spent a good 10 minutes figuring out what your code is trying to do.

This is what I think you're trying to do:


  • You have a list of Salaries, each of which has an ID number.
  • You want to list every combination of 6 salaries where the total of the 6 salaries lies in the range minSalary <= total <= maxSalary
  • You want to choose each item in your list at most once (it is unclear if your salary list can have the same salary listed more than once)
  • You treat totals where the ID Total is the same as duplicates.

Usually I would go through an exhaustive list of things your code needs to fix with examples. Here, I'm just going to tell you everything, and then rewrite your code once using all the things I mention.


Data should be in Arrays

Accessing worksheet objects is incredibly slow. And you're doing it everywhere. Read your sheet data into Arrays, and then read from the arrays. It is at least 100x faster.


Naming

Use Descriptive, unambiguous, naming. I should be able to read a variable and instantly know what it is and what it's doing. I recommend the Excellent, Classic article on naming by Joel spolsky on that subject.


Abstract your operations into their own Subs/Functions

You've done this a little with CheckFlag but you need to do it ruthlessly to make really good code. Anything that reasonably can be abstracted away/compartmentalised should be.


Dictionaries

To use Dictionaries, set a reference to the Microsoft Scripting Runtime in Tools --> References.

A Dictionary is a list of keys and items. Each key is unique and corresponds to exactly one item. So, if you fill a dictionary with (key = salary, item = id) then to get the ID of a salary, all you have to do is ID = Dictionary.Item(Salary)


Comments

Use them. Write a paragraph at the top of your sub describing what it's doing and why. Describe your outcomes. Describe how you're going to get there.

In your code, as much as possible, good naming should make it clear what is going on. Where it doesn't (or where you have to do something very un-intuitive for necessary reasons), leave a comment explaining what's going on and why.


Code

Public Sub PrintAllValidSalaryCombinations()
    '/ subject to the min/max salary constraints,
    '/ list every combination of 6 salaries from the salaries column in the "Pool" sheet where the total satisfies the constraints
    '/ use each item in the list only once.
    '/ Treat combinations with the same [Sum of ID Numbers] as duplicates
    '/ Print resulting combinations to sheet "Results"

    Const MIN_SALARY As Double = 0
    Const MAX_SALARY As Double = 100000

    Dim salariesSheet As Worksheet
    Set salariesSheet = Sheets("pool")

    Dim resultsSheet As Worksheet
    Set resultsSheet = Sheets("results")

    Dim identifiersSheet As Worksheet
    Set identifiersSheet = Sheets("pasted")

    Dim salaryIDs As Dictionary
    Set salaryIDs = GetSalaryIDs(identifiersSheet)

    Dim salariesList As Variant
    salariesList = GetSalariesList(salariesSheet)

    '/ combinations list will come out transposed, so rows = columns and vice versa
    Dim combinationsList As Variant
    combinationsList = GetAllCombinations(salariesList, salaryIDs, MIN_SALARY, MAX_SALARY)

    '/ print to results sheet
    resultsSheet.Cells.ClearContents

    '/ reverse rows and columns
    Dim iRow As Long, iColumn As Long
    For iRow = LBound(combinationsList, 2) To UBound(combinationsList, 2)
        For iColumn = LBound(combinationsList, 1) To UBound(combinationsList, 1)
            With resultsSheet
                .Cells(iRow, iColumn) = combinationsList(iColumn, iRow)
            End With
        Next iColumn
    Next iRow

End Sub

Public Function GetRangeIds(ByRef identifiersSheet As Worksheet) As Dictionary
    '/ Each salary has a corresponding ID number, so we make a dictionary where each ID is keyed by its' salary number

    '/ If these columns ever momves, we only have to change them here. And only once
    Const SALARY_COLUMN As Long = 1
    Const ID_COLUMN As Long = 4

    '/ If we make assumptions, we should always explicitly document them like this
    Const FIRST_ROW As Long = 1

    Dim finalRow As Long
    With identifiersSheet
        finalRow = .Cells(.Rows.Count, SALARY_COLUMN).End(xlUp).Row
    End With

    Dim nameRange As Range
    Dim idRange As Range
    With identifiersSheet
        Set nameRange = .Range(.Cells(FIRST_ROW, SALARY_COLUMN), .Cells(finalRow, SALARY_COLUMN))
        Set idRange = .Range(.Cells(FIRST_ROW, ID_COLUMN), .Cells(finalRow, ID_COLUMN))
    End With

    '/ "Array = Range" populates the array with the data in the range.
    Dim salaryArray As Variant
    salaryArray = nameRange

    Dim idArray As Variant
    idArray = idRange

    Dim idDict As Dictionary
    Set idDict = New Dictionary '/ create our dictionary

    Dim ix As Long
    For ix = LBound(salaryArray, 1) To UBound(salaryArray, 1)
        idDict.Add Key:=CStr(salaryArray(ix)), Item:=CDbl(idArray(ix))
    Next ix

    Set GetRangeIds = idDict

End Function

Public Function GetSalariesList(ByRef salariesSheet As Worksheet) As Variant

    '/ If the salary column ever momves, we only have to change it here. And only once
    Const SALARY_COLUMN As Long = 1

    '/ If we make assumptions, we should always explicitly document them like this
    Const FIRST_ROW As Long = 1

    Dim finalRow As Long
    With salariesSheet
        finalRow = .Cells(.Rows.Count, SALARY_COLUMN).End(xlUp).Row
    End With

    Dim dataRange As Range
    With salariesSheet
        Set dataRange = .Range(.Cells(FIRST_ROW, SALARY_COLUMN), .Cells(finalRow, SALARY_COLUMN))
    End With

    '/ "Array = Range" populates the array with the data in the range.
    GetSalariesList = dataRange

End Function

Public Function GetAllCombinations(ByRef salariesList As Variant, ByRef salaryIDs As Dictionary, ByVal minSalary As Double, ByVal maxSalary As Double)

    Dim totalSalary As Double
    Dim idTotal As Double

    Dim LB1 As Long, UB1 As Long '/ the bounds of salariesList
    LB1 = LBound(salariesList, 1)
    UB1 = UBound(salariesList, 1)

    Dim resultsArray As Long
    ReDim resultsArray(1 To 8, 1 To 1) '/ 1 - 6 will be our salary numbers. 7 will be total Salary. 8 wil be idTotal.

    Dim resultsCounter As Long

    '/ we will add total IDs to a dictionary for checking as we go
    Dim idTotals As Dictionary
    Set idTotals = New Dictionary

    Dim ix_1 As Long
    Dim ix_2 As Long
    Dim ix_3 As Long
    Dim ix_4 As Long
    Dim ix_5 As Long
    Dim ix_6 As Long

    '/ since there's no repeating, we can just iterate upwards with each ix, making sure they are always strictly greater than the one before them.

    For ix_1 = LB1 To UB1 - 5
        For ix_2 = ix_1 + 1 To UB1 - 4
            For ix_3 = ix_2 + 1 To UB1 - 3
                For ix_4 = ix_3 + 1 To UB1 - 2
                    For ix_5 = ix_4 + 1 To UB1 - 1
                        For ix_6 = ix_5 + 1 To UB1

                            '/ line continuation for readability
                            totalSalary = salariesList(ix_1) + salariesList(ix_2) + salariesList(ix_3) _
                                        + salariesList(ix_4) + salariesList(ix_5) + salariesList(ix_6)

                            If totalSalary >= minSalary And totalSalary <= maxSalary Then

                                idTotal = salaryIDs.Item(salariesList(ix_1)) + salaryIDs.Item(salariesList(ix_2)) _
                                        + salaryIDs.Item(salariesList(ix_3)) + salaryIDs.Item(salariesList(ix_4)) _
                                        + salaryIDs.Item(salariesList(ix_5)) + salaryIDs.Item(salariesList(ix_6))

                                If idTotals.Exists(idTotal) Then
                                    '/ is duplicate, ignore
                                Else
                                    idTotals.Add idTotal, idTotal

                                    '/ extends array while preserving all data already in it
                                    resultsCounter = resultsCounter + 1
                                    ReDim Preserve resultsArray(1 To 8, 1 To resultsCounter)

                                    resultsArray(1, resultsCounter) = ix_1
                                    resultsArray(2, resultsCounter) = ix_2
                                    resultsArray(3, resultsCounter) = ix_3
                                    resultsArray(4, resultsCounter) = ix_4
                                    resultsArray(5, resultsCounter) = ix_5
                                    resultsArray(6, resultsCounter) = ix_6
                                    resultsArray(7, resultsCounter) = totalSalary
                                    resultsArray(8, resultsCounter) = idTotal
                                End If

                            End If

                        Next ix_6
                    Next ix_5
                Next ix_4
            Next ix_3
        Next ix_2
    Next ix_1

    GetAllCombinations = resultsArray

End Function

\$\endgroup\$
  • \$\begingroup\$ heh yeah sorry there are times I try to be as detailed as possible and others when i rush and just try to get the code finished. I appreciate the tips and I definitely agree with you. \$\endgroup\$ – Ari F Jun 23 '16 at 20:02
4
\$\begingroup\$

I have not profiled your code loop vs the loop below for execution time, but logically your code loop has to proceed to the innermost level before making any checks.

Also, for the kind of logic checks you're making, you can see some performance gains by making a mathematical comparison for equivalence. You can stop proceeding further if any two of your indices are equal. If any of the indices are equal, then a longer (and quicker) equation with your indices could easily tell if any are equal if the result is zero.

The example below shows (an incomplete) idea of what I mean.

Option Explicit

Sub test()
    Dim j As Long, k As Long, l As Long, m As Long, n As Long, o As Long, p As Long
    Dim Gmax As Integer

    Gmax = 1000
    For j = 1 To Gmax - 5
        For k = 1 To Gmax - 4
            If Not (j - k = 0) Then
                For l = 1 To Gmax - 3
                    If Not (((j - l) * (k - l)) = 0) Then
                        For m = 1 To Gmax - 2
                            If Not (((j - m) * (k - m) * (l - m)) = 0) Then
                                '--- keep going...
                            End If
                        Next m
                    End If
                Next l
            End If
        Next k
    Next j

End Sub
\$\endgroup\$
  • \$\begingroup\$ this is a very crafty way of doing what i wrote with "If j <> k And j <> l ...Then" and more heh. Although I am not sure of the performance gains, I could see if it helps after I finish modifying my code per Tim's suggestions. Ty \$\endgroup\$ – Ari F Jun 21 '16 at 15:43
  • 1
    \$\begingroup\$ You could just have for i = 1 to X, for j = i + 1 to X + 1, for k = j+1 to X + 2 etc. and avoid the if checks altogether. \$\endgroup\$ – Kaz Jun 21 '16 at 19:39
  • \$\begingroup\$ Even better! And I thought I was being clever with math... \$\endgroup\$ – PeterT Jun 21 '16 at 20:16
  • \$\begingroup\$ I am doing that to an extent though, the way my loops are initalized: j = 1, k = 2, l = 3....p = 6 and I loop j from j to Max choices - 5, k from k to Max choices - 4, l from l to max choices - 3.....p from p to Max choices. is this different from what you are trying to say? \$\endgroup\$ – Ari F Jun 23 '16 at 15:25
  • \$\begingroup\$ @AriF your way, you have to check every index against every other index for collisions. The ways we're discussing here, your indexes automatically avoid collisions. \$\endgroup\$ – Kaz Jun 23 '16 at 19:07

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.