# Loop through a unique combinations driven by choices

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.

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
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.

• 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? – Ari F Jun 21 '16 at 15:31
• Should be fine, yes. – Tim Williams Jun 21 '16 at 15:57
• 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! – Ari F Jun 21 '16 at 19:29
• shouldn't i write the arrays this way? Dim arrPool As Range Set arrPool = pool.Range("A1", pool.Cells(Rows.Count, 1).End(xlUp)) ? – Ari F Jun 23 '16 at 19:10
• 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. – Tim Williams Jun 23 '16 at 19:17

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)

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
finalRow = .Cells(.Rows.Count, SALARY_COLUMN).End(xlUp).Row
End With

Dim nameRange As Range
Dim idRange As Range
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)
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

'/ 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


• 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. – Ari F Jun 23 '16 at 20:02

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

• 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 – Ari F Jun 21 '16 at 15:43
• 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. – Kaz Jun 21 '16 at 19:39
• Even better! And I thought I was being clever with math... – PeterT Jun 21 '16 at 20:16
• 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? – Ari F Jun 23 '16 at 15:25
• @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. – Kaz Jun 23 '16 at 19:07